Webrexp (empty) → 1.0
raw patch · 20 files changed
+3418/−0 lines, 20 filesdep +AttoJsondep +HTTPdep +HaXmlsetup-changed
Dependencies added: AttoJson, HTTP, HaXml, array, base, bytestring, containers, directory, filepath, mtl, network, parsec, process, regex-pcre-builtin, transformers
Files
- Setup.hs +3/−0
- Webrexp.cabal +76/−0
- Webrexp.hs +144/−0
- Webrexp/DirectoryNode.hs +124/−0
- Webrexp/Eval.hs +238/−0
- Webrexp/Eval/Action.hs +205/−0
- Webrexp/Eval/ActionFunc.hs +169/−0
- Webrexp/Exprtypes.hs +351/−0
- Webrexp/GraphWalker.hs +152/−0
- Webrexp/HaXmlNode.hs +108/−0
- Webrexp/JsonNode.hs +94/−0
- Webrexp/Log.hs +31/−0
- Webrexp/Parser.hs +260/−0
- Webrexp/ProjectByteString.hs +6/−0
- Webrexp/Remote/MimeTypes.hs +129/−0
- Webrexp/ResourcePath.hs +104/−0
- Webrexp/UnionNode.hs +133/−0
- Webrexp/WebContext.hs +472/−0
- Webrexp/WebRexpAutomata.hs +533/−0
- webrexpMain.hs +86/−0
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ Webrexp.cabal view
@@ -0,0 +1,76 @@+Name: Webrexp+Version: 1.0+Synopsis: Regexp-like engine to scrap web data+Build-Type: Simple+License: BSD3+Cabal-Version: >= 1.8+Description: A web scrapping utility mixing CSS selector syntax and regular expressions+Category: Utility+Author: Vincent Berthoux+Maintainer: Vincent Berthoux (twinside@gmail.com)++Flag optimize+ Description: turn on optimisation+ Default: False++Executable webrexp+ Main-Is: webrexpMain.hs+ Ghc-Options: -Wall++ if flag(optimize)+ Ghc-options:-O3++ Build-Depends: base >= 2.0 && < 5.0, mtl,+ HTTP >= 4000.1.1 && < 4000.2,+ parsec >= 3.1 && < 3.2,+ transformers >= 0.2.2 && < 0.3,+ network >= 2.3 && < 2.4,+ directory >= 1.0,+ bytestring >= 0.9.1.7 && < 1.0,+ containers >= 0.3,+ array >= 0.3,+ regex-pcre-builtin >= 0.94,+ HaXml >= 1.20 && < 1.30,+ AttoJson >= 0.5.1 && < 1.0,+ process >= 1.0.1.3 && < 1.1,+ filepath+ -- Webrexp+++Library+ Ghc-Options: -Wall+ Exposed-Modules: Webrexp,+ Webrexp.Parser,+ Webrexp.Eval,+ Webrexp.Exprtypes,+ Webrexp.GraphWalker,+ Webrexp.ResourcePath++ Other-Modules:+ Webrexp.DirectoryNode+ Webrexp.Eval.Action+ Webrexp.Eval.ActionFunc+ Webrexp.HaXmlNode+ Webrexp.JsonNode+ Webrexp.Log+ Webrexp.ProjectByteString+ Webrexp.Remote.MimeTypes+ Webrexp.UnionNode+ Webrexp.WebContext+ Webrexp.WebRexpAutomata++ Build-Depends: base >= 2.0 && < 5.0, mtl,+ HTTP >= 4000.1.1 && < 4000.2,+ HaXml >= 1.20 && < 1.30,+ parsec >= 3.1 && < 3.2,+ transformers >= 0.2.2 && < 0.3,+ network >= 2.3 && < 2.4,+ directory >= 1.0,+ bytestring >= 0.9.1.7 && < 1.0,+ containers >= 0.3,+ array >= 0.3,+ regex-pcre-builtin >= 0.94,+ AttoJson >= 0.5.1 && < 1.0,+ process >= 1.0.1.3 && < 1.1,+ filepath+
+ Webrexp.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- | Generic module for using Webrexp as a user.+module Webrexp ( + -- * Default evaluation+ evalWebRexp+ , evalWebRexpDepthFirst + , parseWebRexp+ , evalParsedWebRexp++ -- * Crawling configuration+ , Conf (..)+ , defaultConf+ , evalWebRexpWithConf+ ) where++import Control.Monad+import Control.Monad.IO.Class+import Text.Parsec+import System.IO+import System.Exit++import Webrexp.Exprtypes+import Webrexp.Parser( webRexpParser )++import Webrexp.HaXmlNode+import Webrexp.JsonNode+import Webrexp.UnionNode+import Webrexp.DirectoryNode++import Webrexp.ResourcePath+import Webrexp.WebContext++import Webrexp.WebRexpAutomata++data Conf = Conf+ { hammeringDelay :: Int+ , userAgent :: String+ , output :: Handle+ , verbose :: Bool+ , quiet :: Bool+ , expr :: String+ , showHelp :: Bool+ , depthEvaluation :: Bool+ , outputGraphViz :: Bool+ }++defaultConf :: Conf+defaultConf = Conf+ { hammeringDelay = 1500+ , userAgent = ""+ , output = stdout+ , verbose = False+ , quiet = False+ , expr = ""+ , showHelp = False+ , outputGraphViz = False+ , depthEvaluation = True+ }++type CrawledNode =+ UnionNode HaXmLNode+ (UnionNode JsonNode DirectoryNode)++type Crawled a =+ WebCrawler CrawledNode ResourcePath a++initialState :: IO (EvalState CrawledNode ResourcePath)+initialState = do+ node <- currentDirectoryNode + return . Node $ repurposeNode (UnionRight . UnionRight) node++-- | Prepare a webrexp.+-- This function is useful if the expression has+-- to be applied many times.+parseWebRexp :: String -> Maybe WebRexp+parseWebRexp str =+ case runParser webRexpParser () "expr" str of+ Left _ -> Nothing+ Right e -> Just e++-- | Evaluation for pre-parsed webrexp.+-- Best method if a webrexp has to be evaluated+-- many times.+evalParsedWebRexp :: WebRexp -> IO Bool+evalParsedWebRexp wexpr = evalWithEmptyContext crawled+ where crawled :: Crawled Bool = evalBreadthFirst (Text "") wexpr++-- | Simple evaluation function, evaluation is+-- the breadth first type.+evalWebRexp :: String -> IO Bool+evalWebRexp = evalWebRexpWithEvaluator $ evalBreadthFirst (Text "")++evalWebRexpDepthFirst :: String -> IO Bool+evalWebRexpDepthFirst = evalWebRexpWithEvaluator $ evalDepthFirst (Text "")++-- | Simplest function to eval a webrexp.+-- Return the evaluation status of the webrexp,+-- True for full evaluation success.+evalWebRexpWithEvaluator :: (WebRexp -> Crawled Bool) -> String -> IO Bool+evalWebRexpWithEvaluator evaluator str = + case runParser webRexpParser () "expr" str of+ Left err -> do+ putStrLn "Parsing error :\n"+ print err+ return False++ Right wexpr ->+ let crawled :: Crawled Bool = evaluator wexpr+ in evalWithEmptyContext crawled++evalWebRexpWithConf :: Conf -> IO Bool+evalWebRexpWithConf conf =+ case runParser webRexpParser () "expr" (expr conf) of+ Left err -> do+ putStrLn "Parsing error :\n"+ print err+ return False++ Right wexpr -> do+ when (outputGraphViz conf)+ (do let packed = packRefFiltering wexpr+ dumpAutomata (expr conf) stdout $ buildAutomata packed+ exitWith ExitSuccess)++ when (verbose conf) (print wexpr)++ let crawled :: Crawled Bool = do+ setUserAgent $ userAgent conf+ setOutput $ output conf+ setHttpDelay $ hammeringDelay conf+ when (quiet conf) (setLogLevel Quiet)+ when (verbose conf) (setLogLevel Verbose)+ initState <- liftIO initialState+ if depthEvaluation conf+ then evalDepthFirst initState wexpr+ else evalBreadthFirst initState wexpr++ rez <- evalWithEmptyContext crawled++ when (output conf /= stdout)+ (hClose $ output conf)++ return rez+
+ Webrexp/DirectoryNode.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Webrexp.DirectoryNode( DirectoryNode+ , toDirectoryNode+ , currentDirectoryNode+ ) where++import Control.Exception+import Control.Monad.IO.Class+import System.Directory+import System.FilePath++import Webrexp.GraphWalker+import Webrexp.ResourcePath+import Webrexp.UnionNode+import Webrexp.WebContext++type FileName = String++-- | Type introduced to avoid stupid positional+-- errors in the 'DirectoryNode' type.+newtype FullPath = FullPath String+ deriving (Eq, Show)++-- | Type representing a local folder directory as a node+-- (and not as a path)+data DirectoryNode =+ Directory FullPath FileName+ | File FullPath FileName+ deriving (Eq, Show)++extractPath :: DirectoryNode -> FilePath+extractPath (Directory (FullPath a) _) = a+extractPath (File (FullPath a) _) = a++buildParentList :: FilePath -> [DirectoryNode]+buildParentList path = map directoryze nameFullName+ where directoryList = splitDirectories path+ -- First the name of the folder, followed by the whole path+ nameFullName = zip directoryList $ scanl1 (</>) directoryList++ directoryze (name, whole) =+ Directory (FullPath whole) name+++-- | Transform a filepath into a valid directory node+-- if the path is valid in the current system.+toDirectoryNode :: FilePath -> IO (Maybe (NodeContext DirectoryNode ResourcePath))+toDirectoryNode path = do+ existing <- doesFileExist path+ dirExist <- doesDirectoryExist path+ let (wholePath, fname) = splitFileName path+ parentPath = buildParentList wholePath+ case (existing, dirExist) of+ (_, True) -> return . Just $ NodeContext+ { parents = MutableHistory $ reverse parentPath+ , this = Directory (FullPath path) fname+ , rootRef = Local . extractPath $ head parentPath+ }+ (True, _) -> return . Just $ NodeContext+ { parents = MutableHistory $ reverse parentPath+ , this = File (FullPath path) fname+ , rootRef = Local . extractPath $ head parentPath+ }+ _ -> return Nothing++-- | Create a node rooted in the current directory.+currentDirectoryNode :: IO (NodeContext DirectoryNode ResourcePath)+currentDirectoryNode = do+ cwd <- getCurrentDirectory+ node <- toDirectoryNode cwd+ case node of+ Nothing -> error "currentDirectoryNode : node is not a directory/file o_O"+ Just s -> return s++-- | The problem of this instance is the fact that+-- it's a "sink" instance, it accepts everything.+instance PartialGraph DirectoryNode ResourcePath where+ dummyElem = undefined++ isResourceParseable _ (Local _) _ = True+ isResourceParseable _ _ _ = False++ parseResource _ _ _ = Nothing++instance GraphWalker DirectoryNode ResourcePath where+ -- For now, no file attribute, in the future, might+ -- be interesting to map size & other information+ -- here.+ attribOf _ _ = Nothing++ nameOf (Directory _ name) = Just name+ nameOf (File _ name) = Just name++ valueOf (File (FullPath fpath) _) = fpath+ valueOf (Directory (FullPath fpath) _) = fpath++ indirectLinks (File _ _) = []+ indirectLinks (Directory _ _) = []++ accessGraph _ _ = return AccessError++ isHistoryMutable _ = True++ childrenOf (File _ _) = return []+ childrenOf (Directory (FullPath path) _) =+ liftIO $ listDirectory path++++listDirectory :: FilePath -> IO [DirectoryNode]+listDirectory fpath = do+ content <- try $ getDirectoryContents fpath+ case content of+ Left (_ :: IOError) -> return []+ Right lst ->+ mapM (\path -> do+ let wholePath = fpath </> path+ isDir <- doesDirectoryExist wholePath+ let f = if isDir then Directory else File+ return $ f (FullPath wholePath) path)++ $ filter (\a -> a /= "." && a /= "..") lst+
+ Webrexp/Eval.hs view
@@ -0,0 +1,238 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Webrexp.Eval+ (+ -- * Functions+ evalAction,+ evalWebRexpFor + ) where++import Control.Applicative+import Control.Monad+import Data.List++import Webrexp.GraphWalker+import Webrexp.Exprtypes+import Webrexp.WebContext+import Webrexp.Eval.Action+import Webrexp.Log++-- | Given a node search for valid children, check for their+-- validity against the requirement.+searchRefIn :: (GraphWalker node rezPath)+ => Bool -- ^ Do we recurse?+ -> WebRef -- ^ Ref to find+ -> NodeContext node rezPath -- ^ The root nood for the search+ -> WebCrawler node rezPath+ [NodeContext node rezPath] -- ^ The found nodes.+searchRefIn False Wildcard n = do+ children <- childrenOf $ this n+ return [ NodeContext {+ parents = (this n, idx) ^: parents n,+ this = sub,+ rootRef = rootRef n+ } | (sub, idx) <- zip children [0..]]++searchRefIn True Wildcard n = do+ subs <- descendants $ this n+ return [ NodeContext {+ parents = subP ^+ parents n,+ this = sub,+ rootRef = rootRef n+ } | (sub, subP) <- subs ]++searchRefIn True (Elem s) n = do+ subs <- findNamed s $ this n+ return [ NodeContext {+ parents = subP ^+ parents n,+ this = sub,+ rootRef = rootRef n+ } | (sub, subP) <- subs ]++searchRefIn False (Elem s) n = do+ subs <- searchRefIn False Wildcard n+ return [v | v <- subs, nameOf (this v) == Just s]++searchRefIn recurse (OfClass r s) n = do+ subs <- searchRefIn recurse r n+ return [v | v <- subs, attribOf "class" (this v) == Just s]+searchRefIn recurse (Attrib r s) n = do+ subs <- searchRefIn recurse r n+ return [v | v <- subs, attribOf s (this v) /= Nothing]+searchRefIn recurse (OfName r s) n = do+ subs <- searchRefIn recurse r n+ return [v | v <- subs, attribOf "id" (this v) == Just s]++-- | Evaluate the leaf nodes of a webrexp, this way the code+-- can be shared between the Breadth first evaluator and the+-- Depth first one.+evalWebRexpFor :: (GraphWalker node rezPath)+ => WebRexp -> EvalState node rezPath+ -> WebCrawler node rezPath (Bool, [EvalState node rezPath])+evalWebRexpFor (Str str) _ = do+ debugLog "> '\"...\"'"+ return (True, [Text str])++evalWebRexpFor (Action action) e = do+ debugLog "> '[...]'"+ (rez, neoNode) <- evalAction action $ Just e+ dumpActionVal rez+ if isActionResultValid rez+ then case neoNode of+ Nothing -> return (True, [e])+ Just new -> return (True, [new])+ else return (False, [])++evalWebRexpFor (Unique bucket) e = do+ debugLog $ "> '!' (" ++ show bucket ++ ")"+ beenVisited <- visited e+ return (beenVisited, [e])+ where visited (Node n) = checkUnique . show $ rootRef n+ visited (Text s) = checkUnique s+ visited (Blob b) = checkUnique . show $ sourcePath b+ checkUnique s = do+ seen <- hasResourceBeenVisited bucket s+ unless seen+ (setResourceVisited bucket s)+ return $ not seen++evalWebRexpFor (ConstrainedRef s action) e = do+ ref@(valid, lst) <- evalWebRexpFor (Ref s) e+ if not valid+ then return ref+ else do+ lst' <- mapM (evalWebRexpFor $ Action action) lst+ return (any fst lst', concatMap snd lst')+ ++evalWebRexpFor (DirectChild ref) (Node n) = do+ debugLog $ "> direct 'ref' : " ++ show ref+ subs <- searchRefIn False ref n+ let n' = map Node subs+ debugLog $ ">>> found ->" ++ show (length n')+ return (not $ null n', n')++evalWebRexpFor (DirectChild _) _ = return (False, [])++evalWebRexpFor (Ref ref) (Node n) = do+ debugLog $ "> 'ref' : " ++ show ref+ subs <- searchRefIn True ref n+ let n' = map Node subs+ debugLog $ ">>> found ->" ++ show (length n')+ return (not $ null n', n')++evalWebRexpFor (Ref _) _ = return (False, [])++evalWebRexpFor DiggLink e = do+ debugLog "> '>>'"+ e' <- diggLinks e+ return (not $ null e', e')++evalWebRexpFor NextSibling e = do+ debugLog "> '+'"+ subs <- siblingAccessor 1 e + case subs of+ Nothing -> return (False, [])+ Just e' -> return (True, [e'])++evalWebRexpFor PreviousSibling e = do+ debugLog "> '~'"+ subs <- siblingAccessor (-1) e+ case subs of+ Nothing -> return (False, [])+ Just e' -> return (True, [e'])++evalWebRexpFor Parent (Node e) = do+ debugLog "> '<'"+ case parents e of+ ImmutableHistory [] -> return (False, [])+ MutableHistory [] -> return (False, [])+ ImmutableHistory ((n,_):ps) ->+ return (True, [Node $ e { parents = ImmutableHistory ps, this = n }])+ MutableHistory (n:ps) ->+ return (True, [Node $ e { parents = MutableHistory ps, this = n }])++evalWebRexpFor Parent _ = return (False, [])++-- Exaustive definition to get better warning from compiler in case+-- of modification+evalWebRexpFor (Branch _) _ =+ error "evalWebRexpFor - non terminal in terminal function."+evalWebRexpFor (Unions _) _ =+ error "evalWebRexpFor - non terminal in terminal function."+evalWebRexpFor (List _) _ =+ error "evalWebRexpFor - non terminal in terminal function."+evalWebRexpFor (Star _) _ =+ error "evalWebRexpFor - non terminal in terminal function."+evalWebRexpFor (Repeat _ _) _ =+ error "evalWebRexpFor - non terminal in terminal function."+evalWebRexpFor (Alternative _ _) _ =+ error "evalWebRexpFor - non terminal in terminal function."+evalWebRexpFor (Range _ _) _ =+ error "evalWebRexpFor - non terminal in terminal function."++downLinks :: (GraphWalker node rezPath)+ => rezPath+ -> WebCrawler node rezPath [EvalState node rezPath]+downLinks path = do+ loggers <- prepareLogger+ down <- accessGraph loggers path+ case down of+ AccessError -> return []+ DataBlob u b -> return [Blob $ BinBlob u b]+ Result u n -> return [Node + NodeContext { parents = hist+ , rootRef = u+ , this = n }]+ where hist = if isHistoryMutable n+ then MutableHistory []+ else ImmutableHistory []++--------------------------------------------------+---- Helper functions+--------------------------------------------------+diggLinks :: (GraphWalker node rezPath)+ => EvalState node rezPath+ -> WebCrawler node rezPath [EvalState node rezPath]+diggLinks (Node n) =+ concat <$> sequence+ [ downLinks $ rootRef n <//> indir+ | indir <- indirectLinks $ this n ]+diggLinks (Text str) = case importPath str of+ Nothing -> return []+ Just p -> downLinks p+diggLinks _ = return []++-- | Let access sibling nodes with a predefined index.+siblingAccessor :: (GraphWalker node rezPath)+ => Int -> EvalState node rezPath+ -> WebCrawler node rezPath+ (Maybe (EvalState node rezPath))+siblingAccessor 0 node@(Node _) = return $ Just node+siblingAccessor idx (Node node)=+ case parents node of+ ImmutableHistory [] -> return Nothing+ MutableHistory [] -> return Nothing+ ImmutableHistory ((n,i):ps) -> do+ children <- childrenOf n+ let childrenCount = length children+ neoIndex = i + idx+ if neoIndex < 0 || neoIndex >= childrenCount+ then return Nothing+ else return . Just . Node $ NodeContext+ { parents = ImmutableHistory $ (n, neoIndex):ps+ , this = children !! neoIndex+ , rootRef = rootRef node+ }+ MutableHistory (n:_) -> do+ children <- childrenOf n+ let childrenCount = length children+ case elemIndex (this node) children of+ Nothing -> error "Sibling access - root file removed"+ Just i ->+ let neoIndex = i + idx+ in if neoIndex < 0 || neoIndex >= childrenCount+ then return Nothing+ else return . Just . Node $ node+ { this = children !! neoIndex }+siblingAccessor _ _ = return Nothing+
+ Webrexp/Eval/Action.hs view
@@ -0,0 +1,205 @@+module Webrexp.Eval.Action( evalAction + , dumpActionVal+ , isActionResultValid ) where++import Control.Monad+import Control.Monad.IO.Class+import Data.List+import Text.Regex.PCRE++import Webrexp.GraphWalker+import Webrexp.Exprtypes+import Webrexp.WebContext+import Webrexp.Eval.ActionFunc++import Webrexp.Log+import qualified Webrexp.ProjectByteString as B++binArith :: (GraphWalker node rezPath)+ => (ActionValue -> ActionValue -> ActionValue) -- ^ Function to cal result+ -> Maybe (EvalState node rezPath) -- Actually evaluated element+ -> ActionExpr -- Left subaction (tree-like)+ -> ActionExpr -- Right subaction (tree-like)+ -> WebCrawler node rezPath (ActionValue, Maybe (EvalState node rezPath))+binArith _ Nothing _ _ = return (ATypeError, Nothing)+binArith f e sub1 sub2 = do+ (v1,e') <- evalAction sub1 e+ case e' of+ Nothing -> return (ATypeError, Nothing)+ Just _ -> do+ (v2, e'') <- evalAction sub2 e'+ return (v1 `f` v2, e'')++intOnly :: (Int -> Int -> Int) -> ActionValue -> ActionValue -> ActionValue+intOnly f (AInt a) (AInt b) = AInt $ f a b+intOnly _ _ _ = ATypeError++stringOnly :: (String -> String -> String) -> ActionValue -> ActionValue+ -> ActionValue+stringOnly f (AString a) (AString b) = AString $ f a b+stringOnly _ _ _ = ATypeError++stringPredicate :: (String -> String -> Bool) -> ActionValue + -> ActionValue -> ActionValue+stringPredicate f (AString a) (AString b) = ABool $ f a b+stringPredicate _ _ _= ATypeError++intComp :: (Int -> Int -> Bool) -> ActionValue -> ActionValue -> ActionValue+intComp f (AInt a) (AInt b) = ABool $ f a b+intComp _ _ _ = ATypeError++binComp :: ActionValue -> ActionValue -> ActionValue+binComp (AInt a) (AInt b) = ABool $ a == b+binComp (ABool a) (ABool b) = ABool $ a == b+binComp (AString a) (AString b) = ABool $ a == b+binComp ATypeError _ = ATypeError+binComp _ ATypeError = ATypeError+binComp _ _ = ATypeError++boolComp :: (Bool -> Bool -> Bool) -> ActionValue -> ActionValue -> ActionValue+boolComp f (ABool a) (ABool b) = ABool $ f a b+boolComp _ _ _ = ABool False++isActionResultValid :: ActionValue -> Bool+isActionResultValid (ABool False) = False+isActionResultValid (AInt 0) = False+isActionResultValid ATypeError = False+isActionResultValid _ = True++dumpActionVal :: ActionValue -> WebCrawler node rezPath ()+dumpActionVal (AString s) = textOutput s+dumpActionVal (AInt i) = textOutput $ show i+dumpActionVal _ = return ()++dumpContent :: (GraphWalker node rezPath)+ => Maybe (EvalState node rezPath)+ -> WebCrawler node rezPath (ActionValue, Maybe (EvalState node rezPath))+dumpContent Nothing = return (ABool False, Nothing)+dumpContent e@(Just (Node ns)) =+ case indirectLinks (this ns) of+ [] -> return (AString $ valueOf (this ns), e)+ links -> do+ loggers <- prepareLogger+ mapM_ (\l -> dumpDataAtPath loggers $+ rootRef ns <//> l) links+ return (ABool True, e)+dumpContent e@(Just (Text str)) = return (AString str, e)+dumpContent e@(Just (Blob b)) = do+ (norm, _, _) <- prepareLogger+ let filename = localizePath $ sourcePath b+ liftIO . norm $ "Dumping blob in " ++ filename+ liftIO $ B.writeFile filename (blobData b)+ return (ABool True, e)++-- | Evaluate embedded action in WebRexp+evalAction :: (GraphWalker node rezPath)+ => ActionExpr+ -> Maybe (EvalState node rezPath)+ -> WebCrawler node rezPath+ (ActionValue, Maybe (EvalState node rezPath))+evalAction (ActionExprs actions) e = do+ rez <- foldM eval (ABool True, e) actions+ debugLog $ "\t>" ++ show (fst rez)+ return rez+ where eval v@(ABool False, _) _ = do+ debugLog $ "\t|False"+ return v+ eval v@(ATypeError, _) _ = do+ debugLog $ "\t|ATypeError"+ return v+ eval (actionVal, el) act = do+ debugLog $ "\t>" ++ show actionVal+ dumpActionVal actionVal+ evalAction act el++evalAction (NodeReplace sub) e = do+ (val, el) <- evalAction sub e+ case val of+ AInt i -> return (ABool True, Just . Text $ show i)+ ABool True -> return (ABool True, Just $ Text "1")+ ABool False -> return (ABool True, Just $ Text "0")+ AString s -> return (ABool True, Just $ Text s)+ ATypeError -> return (val, el)+ +evalAction (CstI i) n = return (AInt i, n)+evalAction (CstS s) n = return (AString s, n)+evalAction OutputAction e =+ dumpContent e++evalAction (ARef r) e@(Just (Node n)) =+ case attribOf r (this n) of+ Nothing -> return (ABool False, e)+ Just s -> return (AString s, e)++evalAction (ARef _) _ =+ return (ATypeError, Nothing)++evalAction (BinOp OpMatch a b) e =+ binArith (stringPredicate (=~)) e a b+evalAction (BinOp OpAdd a b) e = binArith (intOnly (+)) e a b+evalAction (BinOp OpSub a b) e = binArith (intOnly (-)) e a b+evalAction (BinOp OpMul a b) e = binArith (intOnly (*)) e a b+evalAction (BinOp OpDiv a b) e = binArith (intOnly div) e a b++evalAction (BinOp OpLt a b) e = binArith (intComp (<)) e a b+evalAction (BinOp OpLe a b) e = binArith (intComp (<=)) e a b+evalAction (BinOp OpGt a b) e = binArith (intComp (>)) e a b+evalAction (BinOp OpGe a b) e = binArith (intComp (>=)) e a b++evalAction (BinOp OpEq a b) e = binArith binComp e a b+evalAction (BinOp OpNe a b) e = binArith (\a' b' -> valNot $ binComp a' b') e a b+ where valNot (ABool f) = ABool $ not f+ valNot el = el++evalAction (BinOp OpAnd a b) e = binArith (boolComp (&&)) e a b+evalAction (BinOp OpOr a b) e = binArith (boolComp (||)) e a b+evalAction (BinOp OpConcat a b) e = binArith (stringOnly (++)) e a b++evalAction (BinOp OpContain a b) e =+ binArith (stringPredicate contain) e a b+ where contain att val = val `elem` words att+evalAction (BinOp OpHyphenBegin a b) e = + binArith (stringPredicate contain) e a b+ where contain att val = val == fst (break ('-' ==) att)+evalAction (BinOp OpBegin a b) e =+ binArith (stringPredicate $ flip isPrefixOf) e a b+evalAction (BinOp OpEnd a b) e =+ binArith (stringPredicate $ flip isSuffixOf) e a b+evalAction (BinOp OpSubstring a b) e =+ binArith (stringPredicate $ flip isInfixOf) e a b+++-- We list every possibility for now to be sure to implement+-- everything.+evalAction (Call BuiltinToNum subs) e = actionFunEval toNum subs e+evalAction (Call BuiltinToString subs) e = actionFunEval funToString subs e+evalAction (Call BuiltinTrim subs) e = actionFunEval trimString subs e+evalAction (Call BuiltinFormat subs) e = actionFunEval formatString subs e+evalAction (Call BuiltinSubsitute subs) e = actionFunEval substituteFunc subs e+evalAction (Call BuiltinSystem subs) e = actionFunEvalM funcSysCall subs e++actionFunEval :: (GraphWalker node rezPath)+ => ActionFunc node rezPath+ -> [ActionExpr] -> Maybe (EvalState node rezPath)+ -> WebCrawler node rezPath+ (ActionValue, Maybe (EvalState node rezPath))+actionFunEval f actions st = do+ vals <- mapM (\a -> evalAction a st) actions+ let values = map fst vals+ if all (/= ATypeError) values+ then return $ f values st+ else return (ATypeError, Nothing)+++actionFunEvalM :: (GraphWalker node rezPath)+ => ActionFuncM node rezPath+ -> [ActionExpr] -> Maybe (EvalState node rezPath)+ -> WebCrawler node rezPath+ (ActionValue, Maybe (EvalState node rezPath))+actionFunEvalM f actions st = do+ vals <- mapM (\a -> evalAction a st) actions+ let values = map fst vals+ if all (/= ATypeError) values+ then f values st+ else return (ATypeError, Nothing)+
+ Webrexp/Eval/ActionFunc.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE PatternGuards #-}+module Webrexp.Eval.ActionFunc( ActionValue(..)+ , ActionFunc+ , ActionFuncM+ , toNum + , toString+ , funToString + , trimString+ , formatString + , format+ , substituteFunc+ , funcSysCall+ ) where++import Control.Applicative+import Control.Monad.IO.Class+import Data.Char+import System.Process+import System.Exit++import Debug.Trace++import Webrexp.WebContext++-- | Data used for the evaluation of actions. Represent the+-- whole set of representable data at runtime.+data ActionValue =+ AInt Int+ | ABool Bool+ | AString String+ | ATypeError+ deriving (Eq, Show)++-- | Type used to describe evaluator for function inside+-- webrexp actions.+type ActionFunc node rezPath+ = [ActionValue] -- ^ Argument list+ -> Maybe (EvalState node rezPath) -- ^ Pipeline argument+ -> (ActionValue, Maybe (EvalState node rezPath)) -- ^ Result++type ActionFuncM node rezPath+ = [ActionValue] -- ^ Argument list+ -> Maybe (EvalState node rezPath) -- ^ Pipeline argument+ -> WebCrawler node rezPath+ (ActionValue, Maybe (EvalState node rezPath)) -- ^ Result++-- | Typecast operation, from :+-- - string to int+-- - Bool to int+toNum :: ActionFunc node rezPath+toNum [AString t] a | all isDigit t = (AInt $ read t, a)+toNum [ABool True] a = (AInt 1, a)+toNum [ABool False] a = (AInt 0, a)+toNum [v@(AInt _)] a = (v, a)+toNum _ a = (ATypeError, a)++-- | Convert any value to string+toString :: ActionValue -> String+toString (AString v) = v+toString (ABool True) = "true"+toString (ABool False) = "false"+toString (AInt i) = show i+toString ATypeError = "ATypeError"++funToString :: ActionFunc node rezPath+funToString [ATypeError] a = trace "FUCK" (ATypeError, a)+funToString [v] a = (AString $ toString v, a)+funToString b a = trace (show b) $ (ATypeError, a)+++-- | Remove blank space before and after a string+trimString :: ActionFunc node rezPath+trimString [AString s] a = (AString $ trimm s, a)+ where trimm = reverse . trimBegin . reverse . trimBegin+ trimBegin = dropWhile (\c -> c == ' ' || c == '\t')++trimString _ a = (ATypeError, a)++-- | This function take a string as first parameter+-- (the template string) and a list of string to be+-- inserted at some points.+--+-- The format string is made up of some tagged indices,+-- for example \'{0}\' reference the first inserted content+-- and \'{2}\' the third one. the \'}\' character can be+-- escapped by prefixing it by a \'\\\'+--+-- @+-- format \"da {0} bu {1} \\\\{0} do {1}\" [\"head\", \"second\"]+-- -> Just \"da head bu second {0} do second\"+-- @+--+-- It work as intented, there is no syntax error in the formated+-- string, and all indices are in bound.+--+-- @+-- format \"da {0} bu {1} \\\\{0} do {2}\" [\"head\", \"second\"]+-- -> 'Nothing'+-- @+--+-- the \'2\' index is out of bound, so the function return+-- 'Nothing'+--+-- @+-- format \"da {0} bu {1} \\\\{0} do {1a}\" [\"head\", \"second\"]+-- -> 'Nothing'+-- @+--+-- 'Nothing' is returned because \'1a\' is not a valid index.+format :: String -- ^ Template string+ -> [String] -- ^ Inserted content+ -> Maybe String -- ^ The formated string+format [] _ = Just ""+format ('\\':'{':xs) els = ('{' :) <$> format xs els+format ('{':xs) els = + let maxIndex = length els+ in case span isDigit xs of+ ([], _) -> Nothing+ (_ , []) -> Nothing+ (n, '}':rest) -> let idx = read n in+ if idx >= maxIndex+ then Nothing+ else ((els !! idx) ++) <$> format rest els+ _ -> Nothing+format (x:xs) els = (x:) <$> format xs els++-- | Format a string given a list of action+-- values, if the first parameter is not a+-- string, return a type error.+formatString :: ActionFunc node rezPath+formatString (AString s : rest) a =+ (maybe ATypeError AString . format s $ map toString rest, a)+formatString _ a = (ATypeError, a)++-- | Given a prefix and a list, return the rest+-- of the list +dropPrefix :: (Eq a) => [a] -> [a] -> Maybe [a]+dropPrefix [] lst = Just lst+dropPrefix (x:xs) (y:ys)+ | x == y = dropPrefix xs ys+ | otherwise = Nothing+dropPrefix _ [] = Nothing++-- | Replace globally (for each repeatition)+-- a sublist by another one in a give list+substitute :: (Eq a)+ => [a] -- ^ The substituted list+ -> [a] -- ^ The replaced sublist+ -> [a] -- ^ The replacement+ -> [a]+substitute [] _ _ = []+substitute lst@(_:xs) what by+ | Just rest <- dropPrefix what lst =+ by ++ substitute rest what by+ | otherwise = substitute xs what by++substituteFunc :: ActionFunc node rezPath+substituteFunc [AString s, AString what, AString by] e =+ (AString $ substitute s what by, e)+substituteFunc _ e = (ATypeError, e)++funcSysCall :: ActionFuncM node rezPath+funcSysCall [AString s] e = do+ code <- liftIO $ system s+ case code of+ ExitSuccess -> return (ABool True, e)+ _ -> return (ABool False, e)+funcSysCall _ e = return (ATypeError, e)+
+ Webrexp/Exprtypes.hs view
@@ -0,0 +1,351 @@+-- | Datatypes used to describe webrexps, and some helper functions.+module Webrexp.Exprtypes+ ( + -- * Types+ WebRef (..)+ , NodeRange (..)+ , Op (..)+ , ActionExpr (..)+ , WebRexp (..)+ , RepeatCount (..)+ , BuiltinFunc (..)+ -- * Functions+ -- ** Transformations+ , simplifyNodeRanges + , foldWebRexp+ , assignWebrexpIndices + , prettyShowWebRef+ , packRefFiltering + -- ** Predicates+ , isInNodeRange+ , isOperatorBoolean+ , isActionPredicate+ ) where++import Data.List( sort, mapAccumR )++-- | represent an element+data WebRef =+ -- | \'*\' Any subelement.+ Wildcard+ -- | ... Search for a named element.+ | Elem String+ -- | ... . ... Check the value of the \'class\' attribute+ | OfClass WebRef String+ -- | \@... Check for the presence of an attribute+ | Attrib WebRef String+ -- | #... Check the value of the \'id\' attribute+ | OfName WebRef String+ deriving Show++-- | Ranges to be able to filter nodes by position.+data NodeRange =+ -- | ...+ Index Int+ -- | min-max+ | Interval Int Int+ deriving (Eq, Show)+++instance Ord NodeRange where+ compare (Index a) (Index b) = compare a b+ compare (Index a) (Interval b c)+ | a < b = LT+ | a > c = GT+ -- index is within the interval, put interval+ -- before+ | otherwise = GT+ compare (Interval a _) (Index c)+ | a < c = LT+ | a > c = GT+ | otherwise = LT -- favor interval before+ compare (Interval a b) (Interval c d) =+ case compare a c of+ EQ -> compare b d+ e -> e++simplifySortedNodeRanges :: [NodeRange] -> [NodeRange]+simplifySortedNodeRanges [] = []+simplifySortedNodeRanges [a] = [a]+simplifySortedNodeRanges (i@(Interval a b):idx@(Index c):xs)+ | a <= c && c <= b = simplifySortedNodeRanges (i:xs)+ | otherwise = i : simplifySortedNodeRanges (idx:xs)+simplifySortedNodeRanges (i1@(Index a):i2@(Index b):xs)+ | a == b = simplifySortedNodeRanges (i1:xs)+ | otherwise = i1 : simplifySortedNodeRanges (i2:xs)+simplifySortedNodeRanges (i1@(Index _):i2@(Interval _ _):xs) =+ i1 : simplifySortedNodeRanges (i2:xs)+simplifySortedNodeRanges (i1@(Interval a b):i2@(Interval c d):xs)+ | a <= c && c <= b = -- there is intersection, pick the union+ simplifySortedNodeRanges $ Interval a (max b d) : xs+ | otherwise = i1 : simplifySortedNodeRanges (i2:xs)++-- | This function is an helper function to simplify+-- the handling the node range. After simplification,+-- the ranges are sorted in ascending order and no+-- node range overlap.+simplifyNodeRanges :: [NodeRange] -> [NodeRange]+simplifyNodeRanges = simplifySortedNodeRanges . sort . map rangeRearranger+ where rangeRearranger i@(Index _) = i+ rangeRearranger i@(Interval a b)+ | a == b = Index a+ | a > b = Interval b a+ | otherwise = i++-- | Definitions of the operators available in+-- the actions of the webrexp.+data Op =+ OpAdd -- ^ '+'+ | OpSub -- ^ '-'+ | OpMul -- ^ '*'+ | OpDiv -- ^ 'div'+ | OpLt -- ^ '<'+ | OpLe -- ^ '<='+ | OpGt -- ^ '>'+ | OpGe -- ^ '>='+ | OpEq -- ^ \'=\' in webrexp ('==' in Haskell)+ | OpNe -- ^ \'!=\' ('/=' in Haskell)+ | OpAnd -- ^ \'&\' ('&&' in Haksell)+ | OpOr -- ^ \'|\' ('||' in Haskell)+ | OpMatch -- ^ \'=~\' regexp matching++ | OpContain -- ^ \'~=\' op contain, as the CSS3 operator.+ | OpBegin -- ^ \'^=\' op beginning, as the CSS3 operator.+ | OpEnd -- ^ \'$=\' op beginning, as the CSS3 operator.+ | OpSubstring -- ^ \'^=\' op beginning, as the CSS3 operator.+ | OpHyphenBegin -- ^ \'|=\' op beginning, as the CSS3 operator.++ | OpConcat -- ^ \':\' concatenate two strings+ deriving (Eq, Show, Enum)++-- | Type used to index built-in functions +-- in actions.+data BuiltinFunc =+ BuiltinTrim+ | BuiltinSubsitute+ | BuiltinToNum+ | BuiltinToString+ | BuiltinFormat+ | BuiltinSystem+ deriving (Eq, Show, Enum)++-- | Represent an action Each production+-- of the grammar more or less map to a+-- data constructor of this type.+data ActionExpr =+ -- | { ... ; ... ; ... ; ... }+ -- A list of action to execute, each+ -- one must return a 'valid' value to+ -- continue the evaluation+ ActionExprs [ActionExpr]+ -- | Basic binary opertor application+ | BinOp Op ActionExpr ActionExpr++ -- | Find a value of a given attribute for+ -- the current element.+ | ARef String+ -- | An integer constant.+ | CstI Int++ -- | A string constant+ | CstS String++ -- | \'$\'... operator+ -- Used to put the action value back into+ -- the evaluation pipeline.+ | NodeReplace ActionExpr++ -- | the '.' action. Dump the content of+ -- the current element.+ | OutputAction++ -- | funcName(..., ...)+ | Call BuiltinFunc [ActionExpr]+ deriving (Eq, Show)++data RepeatCount =+ RepeatTimes Int+ | RepeatAtLeast Int+ | RepeatBetween Int Int+ deriving (Show)++-- | Type representation of web-regexp,+-- main type.+data WebRexp =+ -- | ( ... ; ... ; ... )+ Branch [WebRexp]+ -- | ( ... , ... , ... )+ | Unions [WebRexp]+ -- | ... ... (each action followed, no rollback)+ | List [WebRexp]+ -- | ... *+ | Star WebRexp+ -- | ... #{ }+ | Repeat RepeatCount WebRexp+ -- | \'|\' Represent two alternative path, if+ -- the first fail, the second one is taken+ | Alternative WebRexp WebRexp+ -- | \'!\'+ -- Possess an unique index to differentiate all the differents+ -- uniques. Negative value are considered invalid, all positive or+ -- null one are accepted.+ | Unique Int+ -- | \"...\" A string constant in the source expression.+ | Str String+ -- | \"{ ... }\"+ | Action ActionExpr+ -- | \'[ ... ]\' Filtering Range+ -- The Int is used as an index for a counter + -- in the DFS evaluator.+ | Range Int [NodeRange]+ -- | every tag/class name+ | Ref WebRef+ -- | Find children who are the different descendent of+ -- the current nodes.+ | DirectChild WebRef+ -- | This constructor is an optimisation, it+ -- combine an Ref followed by an action, where+ -- every action is a predicate. Help pruning+ -- quickly the evaluation tree in DFS evaluation.+ | ConstrainedRef WebRef ActionExpr++ -- | \'>>\' operator in the language, used+ -- to follow hyper link+ | DiggLink++ -- | \'+\' operator in the language, used+ -- to select the next sibling node.+ | NextSibling++ -- | \'~\' operator in the language, used+ -- to select the previous sibling node.+ | PreviousSibling++ -- | \'<\' operator in the language. + -- Select the parent node+ | Parent+ deriving Show++-- | Tell if an action operator return a boolean+-- operation. Useful to tell if an action is a+-- predicate. See 'isActionPredicate'+isOperatorBoolean :: Op -> Bool+isOperatorBoolean op = op `elem`+ [ OpLt, OpLe, OpGt, OpGe, OpEq, OpNe+ , OpAnd, OpOr, OpMatch+ + -- All CSS 3 operators+ , OpContain, OpBegin, OpEnd, OpSubstring+ , OpHyphenBegin ]++-- | Tell if an action is a predicate and is only+-- used to filter nodes. Expression can be modified+-- with this information to help prunning as soon+-- as possible with the DFS evaluator.+isActionPredicate :: ActionExpr -> Bool+isActionPredicate (BinOp op _ _) = isOperatorBoolean op+isActionPredicate _ = False++-- | This function permit the rewriting of a wabrexp in a depth-first+-- fashion while carying out an accumulator.+foldWebRexp :: (a -> WebRexp -> (a, WebRexp)) -> a -> WebRexp -> (a, WebRexp)+foldWebRexp f acc (Repeat count sub) = f acc' $ Repeat count sub'+ where (acc', sub') = foldWebRexp f acc sub+foldWebRexp f acc (Alternative a b) = f acc'' $ Alternative a' b'+ where (acc', a') = foldWebRexp f acc a+ (acc'', b') = foldWebRexp f acc' b+foldWebRexp f acc (Unions subs) = f acc' $ Unions subs'+ where (acc', subs') = mapAccumR (foldWebRexp f) acc subs+foldWebRexp f acc (Branch subs) = f acc' $ Branch subs'+ where (acc', subs') = mapAccumR (foldWebRexp f) acc subs+foldWebRexp f acc (List subs) = f acc' $ List subs'+ where (acc', subs') = mapAccumR (foldWebRexp f) acc subs+foldWebRexp f acc (Star sub) = f acc' $ Star sub'+ where (acc', sub') = foldWebRexp f acc sub+-- This part is exaustive to let the compiler emit a warning if+-- we modify the definition of the WebRexp type+foldWebRexp f acc e@(ConstrainedRef _ _) = f acc e+foldWebRexp f acc e@(DirectChild _) = f acc e+foldWebRexp f acc e@(Unique _) = f acc e+foldWebRexp f acc e@(Str _) = f acc e+foldWebRexp f acc e@(Action _) = f acc e+foldWebRexp f acc e@(Range _ _) = f acc e+foldWebRexp f acc e@(Ref _) = f acc e+foldWebRexp f acc e@DiggLink = f acc e+foldWebRexp f acc e@NextSibling = f acc e+foldWebRexp f acc e@PreviousSibling = f acc e+foldWebRexp f acc e@Parent = f acc e++-- | Preparation function for webrexp, assign all indices+-- used for evaluation as an automata.+assignWebrexpIndices :: WebRexp -> (Int, Int, WebRexp)+assignWebrexpIndices expr = (uniqueCount, rangeCount, packRefFiltering fexpr)+ where (uniqueCount, expr') = setUniqueIndices expr+ (rangeCount, fexpr) = setRangeIndices expr'++packRefFiltering :: WebRexp -> WebRexp+packRefFiltering = snd . foldWebRexp packer ()+ where packer () (List lst) = ((), List $ refActionFind lst)+ packer () a = ((), a)++ refActionFind [] = []+ refActionFind (Ref a: Action act: xs) =+ case actionSpliter act of+ ([], _) -> Ref a : Action act : refActionFind xs+ (some, []) ->+ ConstrainedRef a (actioner some) : refActionFind xs+ (some, [rest]) -> + ConstrainedRef a (actioner some) : Action rest + : refActionFind xs+ (some, rest) -> + ConstrainedRef a (actioner some) : Action (actioner rest)+ : refActionFind xs++ refActionFind (x:xs) = x : refActionFind xs++ actioner [a] = a+ actioner x = ActionExprs x++ actionSpliter (ActionExprs exprs) =+ break isActionPredicate exprs+ actionSpliter a = if isActionPredicate a+ then ([a], [])+ else ([], [a])++-- | Set the index for every unique, return the+-- new webrexp and the count of unique element+setUniqueIndices :: WebRexp -> (Int, WebRexp)+setUniqueIndices expr = foldWebRexp uniqueCounter 0 expr+ where uniqueCounter acc (Unique _) = (acc + 1, Unique acc)+ uniqueCounter acc e = (acc, e)+++-- | Set the indices for the Range constructor (filtering+-- by ID).+setRangeIndices :: WebRexp -> (Int, WebRexp)+setRangeIndices expr = foldWebRexp uniqueCounter 0 expr+ where uniqueCounter acc (Range _ r) = (acc + 1, Range acc r)+ uniqueCounter acc e = (acc, e)++-- | Pretty printing for 'WebRef'. It's should be reparsable+-- by the WebRexp parser.+prettyShowWebRef :: WebRef -> String+prettyShowWebRef Wildcard = "_"+prettyShowWebRef (Elem s) = s+prettyShowWebRef (OfClass r s) = prettyShowWebRef r ++ "." ++ s+prettyShowWebRef (Attrib r s) = prettyShowWebRef r ++ "@" ++ s+prettyShowWebRef (OfName r s) = prettyShowWebRef r ++ "#" ++ s++-- | Helper function to check if a given in dex is within+-- all the ranges+isInNodeRange :: Int -> [NodeRange] -> Bool+isInNodeRange _ [] = False+isInNodeRange i (Index ii:xs)+ | i == ii = True+ | i < ii = False+ | otherwise = isInNodeRange i xs+isInNodeRange i (Interval beg end:xs)+ | beg <= i && i <= end = True+ | beg >= i = False+ | otherwise = isInNodeRange i xs+
+ Webrexp/GraphWalker.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+-- | This module store the interface between the evaluator+-- and the manipulated graph.+module Webrexp.GraphWalker+ ( + -- * Classes+ GraphWalker(..)+ , GraphPath(..)++ -- * Commodity types+ , AccessResult(..)+ , Logger+ , Loggers+ , NodePath++ -- * Helper functions.+ , descendants + , findNamed+ , findFirstNamed + ) where++import Control.Applicative+import Control.Monad.IO.Class+import qualified Webrexp.ProjectByteString as B++-- | Represent the path used to find the node+-- from the starting point of the graph.+type NodePath a = [(a,Int)]++-- | Type used to propagate different logging+-- level across the software.+type Logger = String -> IO ()++-- | Normal/Err/verbose loggers.+type Loggers = (Logger, Logger, Logger)++-- | Represent indirect links or links which+-- necessitate the use of the IO monad to walk+-- around the graph.+class (Show a) => GraphPath a where+ -- | Combine two path togethers, you can think+ -- of the </> operator for an equivalence.+ (<//>) :: a -> a -> a++ -- | conversion to be used to import path+ -- from attributes/document (not really+ -- well specified).+ importPath :: String -> Maybe a++ -- | Move semantic, try to dump the pointed+ -- resource to the current folder.+ dumpDataAtPath :: (Monad m, MonadIO m)+ => Loggers -> a+ -> m ()++ -- | Given a graphpath, transform it to+ -- a filepath which can be used to store+ -- a node.+ localizePath :: a -> FilePath++-- | Result of indirect access demand.+data AccessResult a rezPath =+ -- | We got a result and parsed it, maybe+ -- it has changed of location, so we give+ -- back the location+ Result rezPath a+ -- | We got something, but we can't interpret+ -- it, so we return a binary blob.+ | DataBlob rezPath B.ByteString+ -- | Cannot access the resource.+ | AccessError++-- | The aim of this typeclass is to permit+-- the use of different html/xml parser if+-- if the first one is found to be bad. All+-- the logic should use this interface.+--+-- Minimal implementation : everything.+class (GraphPath rezPath, Eq a)+ => GraphWalker a rezPath | a -> rezPath where+ -- | Get back an attribute of the node+ -- if it exists+ attribOf :: String -> a -> Maybe String++ -- | If the current node is named, return+ -- it's name, otherwise return Nothing.+ nameOf :: a -> Maybe String++ -- | Get all the children of the current+ -- node.+ childrenOf :: (MonadIO m) => a -> m [a]++ -- | Retrieve the value of the tag (textual)+ valueOf :: a -> String++ -- | Retrieve all the indirectly linked content+ -- of a node, can be used for element like an+ -- HTML link or an linked image/obj+ indirectLinks :: a -> [rezPath]++ -- | The idea behind link following.+ -- The graph engine may have another name for the+ -- resource, so an updated name can be given.+ -- The given function is there to log information,+ -- the second is to log errors+ accessGraph :: (MonadIO m)+ => Loggers -> rezPath -> m (AccessResult a rezPath)++ -- | Tell if the history associated is fixed or not.+ -- If the history is not fixed and can change (if you+ -- are querying the filesystem for example, it should+ -- return False)+ isHistoryMutable :: a -> Bool++-- | Return a list of all the "children"/linked node of a given node.+-- The given node is not included in the list.+-- A list of node with the taken path is returned.+descendants :: (MonadIO m, GraphWalker a r) => a -> m [(a, [(a, Int)])]+descendants node = findDescendants (node, [])+ where findDescendants (a, hist) = do+ children <- childrenOf a+ let lst = [ (child, (a,idx) : hist)+ | (child, idx) <- zip children [0..]]+ xs <- mapM findDescendants lst+ return . concat $ lst : xs++-- | Given a tag and a name, retrieve+-- the first matching tags in the hierarchy.+-- It must return the list of ancestors permitting+-- the acess to the path used to find children+--+-- the returned list must contain : the node itself if+-- it match the name, and all the children containing the+-- good name.+findNamed :: (Functor m, MonadIO m, GraphWalker a r)+ => String -> a -> m [(a, [(a, Int)])]+findNamed name node = if nameOf node == Just name+ then ((node, []) :) <$> validChildren+ else validChildren+ where validChildren = filter (\(c,_) -> nameOf c == Just name)+ <$> descendants node++-- | Return the first found node if any.+findFirstNamed :: (Functor m, MonadIO m, GraphWalker a r)+ => String -> [a] -> m (Maybe (a, [(a,Int)]))+findFirstNamed name lst = do+ nameList <- mapM (findNamed name) lst+ case concat nameList of+ [] -> return Nothing+ (x:_) -> return $ Just x+
+ Webrexp/HaXmlNode.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Webrexp.HaXmlNode( HaXmLNode ) where++import Control.Applicative+import Control.Monad.IO.Class+import Data.Maybe( catMaybes )+import Network.HTTP+import Network.URI+import Text.XML.HaXml.Types+import Text.XML.HaXml.Posn+import Text.XML.HaXml.Parse+import Text.XML.HaXml.Html.Parse+import System.Directory++import qualified Webrexp.ProjectByteString as B++import Webrexp.GraphWalker+import Webrexp.ResourcePath+import Webrexp.Remote.MimeTypes+import Webrexp.UnionNode++type HaXmLNode = Content Posn++instance PartialGraph HaXmLNode ResourcePath where+ dummyElem = undefined++ isResourceParseable _ _ ParseableHTML = True+ isResourceParseable _ _ ParseableXML = True+ isResourceParseable _ _ _ = False++ parseResource _ ParseableHTML bindata = Just $ CElem e noPos+ where (Document _prolog _ e _) = htmlParse "" $ B.unpack bindata+ parseResource _ ParseableXML bindata =+ case xmlParse' "" $ B.unpack bindata of+ Left _ -> Nothing+ Right (Document _prolog _ e _) -> Just $ CElem e noPos+ parseResource _ _ _ = error "Cannot parse"++instance GraphWalker HaXmLNode ResourcePath where+ accessGraph = loadHtml+++ attribOf attrName (CElem (Elem _ attrList _) _) =+ show <$> lookup attrName attrList+ attribOf _ _ = Nothing++ childrenOf = return . pureChildren++ nameOf (CElem (Elem n _ _) _) = Just n+ nameOf _ = Nothing++ indirectLinks n =+ catMaybes [ attribOf "href" n >>= importPath+ , attribOf "src" n >>= importPath ]++ isHistoryMutable _ = False++ valueOf (CString _ sdata _) = sdata+ valueOf a = case pureChildren a of+ (CString _ txt _:_) -> txt+ _ -> ""++pureChildren :: HaXmLNode -> [HaXmLNode]+pureChildren (CElem (Elem _ _ children) _) = children+pureChildren _ = []++parserOfKind :: Maybe ParseableType+ -> ResourcePath+ -> B.ByteString -> AccessResult HaXmLNode ResourcePath+parserOfKind Nothing datapath = DataBlob datapath+parserOfKind (Just ParseableHTML) datapath = \file ->+ let (Document _prolog _ e _) = htmlParse "" $ B.unpack file+ in Result datapath $ CElem e noPos+parserOfKind (Just ParseableXML) datapath = \file ->+ case xmlParse' "" $ B.unpack file of+ Left _ -> AccessError+ Right (Document _prolog _ e _) -> Result datapath $ CElem e noPos+parserOfKind (Just ParseableJson) datapath = DataBlob datapath++-- | Given a resource path, do the required loading+loadHtml :: (MonadIO m)+ => Loggers -> ResourcePath+ -> m (AccessResult HaXmLNode ResourcePath)+loadHtml (logger, _errLog, _verbose) datapath@(Local s) = do+ liftIO . logger $ "Opening file : '" ++ s ++ "'"+ realFile <- liftIO $ doesFileExist s+ if not realFile+ then return AccessError+ else do file <- liftIO $ B.readFile s+ let kind = getParseKind s+ return $ parserOfKind kind datapath file++loadHtml loggers@(logger, _, verbose) datapath@(Remote uri) = do+ liftIO . logger $ "Downloading URL : '" ++ show uri ++ "'"+ (u, rsp) <- downloadBinary loggers uri+ let contentType = retrieveHeaders HdrContentType rsp+ case contentType of+ [] -> return AccessError+ (hdr:_) ->+ let logString = "Downloaded (" ++ show u ++ ") ["+ ++ hdrValue hdr ++ "] "+ + kind = getParseKind (uriPath uri)+ in do liftIO $ verbose logString+ return . parserOfKind kind datapath $ rspBody rsp+
+ Webrexp/JsonNode.hs view
@@ -0,0 +1,94 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Webrexp.JsonNode( JsonNode ) where++import Control.Arrow+import Control.Applicative+import Control.Monad.IO.Class+import Data.Maybe( catMaybes )+import qualified Data.Map as Map+import Network.HTTP+import System.Directory+import Text.JSON.AttoJSON++import qualified Webrexp.ProjectByteString as B++import Webrexp.GraphWalker+import Webrexp.ResourcePath+import Webrexp.UnionNode+import Webrexp.Remote.MimeTypes++type JsonNode = (Maybe String, JSValue)++instance PartialGraph JsonNode ResourcePath where+ dummyElem = undefined++ isResourceParseable _ _ ParseableJson = True+ isResourceParseable _ _ _ = False++ parseResource _ ParseableJson binData = (,) Nothing <$> readJSON binData+ parseResource _ _ _ = error "Wrong kind of parser used"++instance GraphWalker JsonNode ResourcePath where+ accessGraph = loadJson++ attribOf attrName (_, JSObject obj) =+ valueOf . none <$> Map.lookup (B.pack attrName) obj+ where none a = (Nothing :: Maybe String, a)+ attribOf _ _ = Nothing++ childrenOf (_, JSArray children) =+ return $ (,) Nothing <$> children+ childrenOf (_, JSObject obj) =+ return $ first (Just . B.unpack) <$> Map.assocs obj+ childrenOf _ = return []++ nameOf (Just s, _) = Just s+ nameOf _ = Nothing++ indirectLinks n =+ catMaybes [ attribOf "href" n >>= importPath+ , attribOf "src" n >>= importPath ]++ isHistoryMutable _ = False++ valueOf (_, JSString s) = B.unpack s+ valueOf (_, JSNumber i) = show i+ valueOf (_, JSBool b) = show b+ valueOf (_, JSArray _) = ""+ valueOf (_, JSObject _) = ""+ valueOf (_, JSNull) = ""++parseJson :: (MonadIO m)+ => Loggers -> ResourcePath -> B.ByteString+ -> m (AccessResult JsonNode ResourcePath)+parseJson (_, errLog, _) datapath file =+ case parseJSON file of+ Left err -> do liftIO . errLog $ "> JSON Parsing error " ++ err+ return AccessError+ Right valid -> return $ Result datapath (Nothing, valid)++-- | Given a resource path, do the required loading+loadJson :: (MonadIO m)+ => Loggers -> ResourcePath+ -> m (AccessResult JsonNode ResourcePath)+loadJson loggers@(logger, _errLog, _verbose) datapath@(Local s) = do+ liftIO . logger $ "Opening file : '" ++ s ++ "'"+ realFile <- liftIO $ doesFileExist s+ if not realFile+ then return AccessError+ else do file <- liftIO $ B.readFile s+ parseJson loggers datapath file++loadJson loggers@(logger, _, verbose) datapath@(Remote uri) = do+ liftIO . logger $ "Downloading URL : '" ++ show uri ++ "'"+ (u, rsp) <- downloadBinary loggers uri+ let contentType = retrieveHeaders HdrContentType rsp+ case contentType of+ [] -> return AccessError+ (hdr:_) ->+ do liftIO . verbose $ "Downloaded (" ++ show u ++ ") ["+ ++ hdrValue hdr ++ "] "+ parseJson loggers datapath $ rspBody rsp+
+ Webrexp/Log.hs view
@@ -0,0 +1,31 @@++-- | Implementation of the (rather basic) logging facility. +--+-- Avoid using 'putStrLn' or 'putStr' in the project, favor+-- using this module.+module Webrexp.Log ( + debugLog+ , textOutput + ) where++import System.IO+import Control.Monad+import Control.Monad.IO.Class+import Webrexp.WebContext++-- | Debugging function, only displayed in verbose+-- logging mode.+debugLog :: String -> WebCrawler node rezPath ()+debugLog str = do+ verb <- isVerbose+ when verb (liftIO $ putStrLn str)+++-- | If a webrexp output some text, it must go through+-- this function. It ensure the writting in the correct+-- file.+textOutput :: String -> WebCrawler node rezPath ()+textOutput str = do+ handle <- getOutput+ liftIO $ hPutStr handle str+
+ Webrexp/Parser.hs view
@@ -0,0 +1,260 @@+-- | Module implementing the parsing of webrexp.+-- It shouldn't be used directly.+module Webrexp.Parser( webRexpParser ) where++import Control.Applicative( (<$>), (<$), (<*>) )+import Control.Monad.Identity+import qualified Data.Map as Map++import Webrexp.Exprtypes++import Text.Parsec.Expr+import Text.Parsec+import Text.Parsec.Language( haskellStyle )+import qualified Text.Parsec.Token as P++-- | Parser used to parse a webrexp.+-- Use just like any 'Parsec' 3.0 parser.+webRexpParser :: ParsecT String st Identity WebRexp+webRexpParser = webrexp ++-- | Little shortcut.+type Parsed st b = ParsecT String st Identity b++-----------------------------------------------------------+-- Lexing defs+-----------------------------------------------------------+reservedOp :: String -> Parsed st ()+reservedOp = P.reservedOp lexer++natural :: Parsed st Integer+natural = P.natural lexer++stringLiteral :: Parsed st String+stringLiteral = P.stringLiteral lexer++parens :: ParsecT String u Identity a + -> ParsecT String u Identity a+parens = P.parens lexer++brackets :: ParsecT String u Identity a + -> ParsecT String u Identity a+brackets = P.brackets lexer++whiteSpace :: Parsed st ()+whiteSpace = P.whiteSpace lexer++lexer :: P.GenTokenParser String st Identity+lexer = P.makeTokenParser + (haskellStyle { P.reservedOpNames = [ "&", "|", "<", ">"+ , "*", "/", "+", "-"+ , "^", "=", "!", ":"+ , "_", "$", "~"+ ]+ , P.identStart = letter+ } )++-----------------------------------------------------------+-- Real "grammar"+-----------------------------------------------------------+webrexpCombinator :: OperatorTable String st Identity WebRexp+webrexpCombinator =+ [ [ postfix "*" Star+ , Postfix repeatOperator ]+ , [ binary "|" Alternative AssocLeft ]+ ]++operatorDefs :: OperatorTable String st Identity ActionExpr+operatorDefs = + [ [binary "/" (BinOp OpDiv) AssocLeft+ ,binary "*" (BinOp OpMul) AssocLeft]+ , [binary "+" (BinOp OpAdd) AssocLeft+ ,binary "-" (BinOp OpSub) AssocLeft+ ,binary ":" (BinOp OpConcat) AssocLeft]+ , [binary "=" (BinOp OpEq) AssocRight+ ,binary "!=" (BinOp OpNe) AssocLeft+ ,binary "=~" (BinOp OpMatch) AssocLeft+ ,binary "~=" (BinOp OpContain) AssocLeft++ -- CSS compatibility...+ ,binary "~=" (BinOp OpContain) AssocLeft+ ,binary "^=" (BinOp OpBegin) AssocLeft+ ,binary "$=" (BinOp OpEnd) AssocLeft+ ,binary "*=" (BinOp OpSubstring) AssocLeft+ ,binary "|=" (BinOp OpHyphenBegin) AssocLeft++ ,binary "<" (BinOp OpLt) AssocLeft+ ,binary ">" (BinOp OpGt) AssocLeft+ ,binary "<=" (BinOp OpLe) AssocLeft+ ,binary ">=" (BinOp OpGe) AssocLeft]+ , [binary "&" (BinOp OpAnd) AssocLeft+ ,binary "|" (BinOp OpOr) AssocLeft]+ , [prefix "$" NodeReplace]+ ]++functionMap :: Map.Map String BuiltinFunc+functionMap = Map.fromList+ [ ("trim" , BuiltinTrim)+ , ("replace", BuiltinSubsitute)+ , ("to_num" , BuiltinToNum)+ , ("to_str" , BuiltinToString)+ , ("format" , BuiltinFormat)+ , ("sys" , BuiltinSystem)+ ]+++-- | Parse some range+noderange :: Parsed st NodeRange+noderange = do+ n <- fromInteger <$> natural+ (do _ <- char '-' + m <- fromInteger <$> natural+ return $ Interval n m) <|> return (Index n)++rangeParser :: Parsed st WebRexp+rangeParser = do+ string "#{" >> whiteSpace+ vals <- sepBy noderange separator+ _ <- whiteSpace >> char '}'+ return . Range (-1) $ simplifyNodeRanges vals+ where separator = whiteSpace >> char ',' >> whiteSpace++webrexpOp :: Parsed st WebRexp+webrexpOp = (DiggLink <$ string ">>")+ <|> (PreviousSibling <$ char '~')+ <|> (NextSibling <$ char '+')+ <|> (Parent <$ char '<')+ <|> (Unique (-1) <$ char '!')+ <?> "webrexpOp"++repeatCount :: Parsed st RepeatCount+repeatCount = do+ begin <- fromInteger <$> natural+ parseComma begin <|> return (RepeatTimes begin)+ where parseComma firstNum = do+ whiteSpace+ _ <- char ','+ whiteSpace+ parseLastNumber firstNum <|> return+ (RepeatAtLeast firstNum) + + parseLastNumber firstNum = do+ endNum <- fromInteger <$> natural+ return $ RepeatBetween firstNum endNum++repeatOperator :: Parsed st (WebRexp -> WebRexp)+repeatOperator = (do+ whiteSpace+ _ <- char '{' >> whiteSpace+ counts <- repeatCount+ _ <- whiteSpace >> char '}' >> whiteSpace+ return $ Repeat counts) <?> "#{repeat}"++webident :: Parsed st String+webident = many1 (alphaNum <|> char '-' <|> char '_')+ <?> "webident"++webrefop :: Parsed st (WebRef -> String -> WebRef)+webrefop = (OfClass <$ char '.')+ <|> (Attrib <$ char '@')+ <|> (OfName <$ char '#')+ <?> "webrefop"++webref :: Parsed st WebRef+webref = do+ initialIdent <- webident+ let initial = if initialIdent == "_"+ then Wildcard+ else Elem initialIdent + (do op <- webrefop+ next <- webident+ return $ op initial next) <|> return initial++actionCall :: Parsed st ActionExpr+actionCall = do+ ident <- webident+ (char '(' >> funParser ident) <|> return (ARef ident)+ where funParser ident = do+ args <- sepBy1 actionExpr (spaceSurrounded $ char ',')+ _ <- whiteSpace >> char ')'+ case Map.lookup ident functionMap of+ Nothing -> error $ "Unknown function " ++ ident+ Just b -> return $ Call b args++actionTerm :: Parsed st ActionExpr+actionTerm = (CstI . fromIntegral <$> natural)+ <|> parens actionExpr+ <|> (CstS <$> stringLiteral)+ <|> (OutputAction <$ char '.')+ <|> actionCall+ <?> "actionTerm"++actionExpr :: Parsed st ActionExpr+actionExpr = (char '$' >> whiteSpace >> NodeReplace <$> wholeExpr)+ <|> wholeExpr+ <?> "actionExpr"+ where wholeExpr = buildExpressionParser operatorDefs (spaceSurrounded actionTerm)++actionList :: Parsed st ActionExpr+actionList = (aexpr <$>+ sepBy actionExpr (whiteSpace >> char ';' >> whiteSpace))+ <?> "actionList"+ where aexpr [a] = a+ aexpr b = ActionExprs b++webrexp :: Parsed st WebRexp+webrexp = (do path <- exprUnion+ rest <- (recParser <|> return [])+ return . aBrancher $ path : rest) <?> "webrexp"+ where separator = whiteSpace >> char ';' >> whiteSpace+ aBrancher [a] = a+ aBrancher a = Branch a+ recParser = separator >>+ ((do p <- exprUnion+ ((p:) <$> recParser) <|> return [p]) <|> return [List []])+++exprUnion :: Parsed st WebRexp+exprUnion = unioner <$> exprPath `sepBy1` separator+ where separator = whiteSpace >> char ',' >> whiteSpace+ unioner [a] = a+ unioner a = Unions a++exprPath :: Parsed st WebRexp+exprPath = (list <$> many1 expr)+ <?> "exprPath"+ where list [a] = a+ list a = List a++expr :: Parsed st WebRexp+expr = buildExpressionParser webrexpCombinator (spaceSurrounded expterm)+ <?> "expr"++expterm :: Parsed st WebRexp+expterm = parens webrexp+ <|> brackets (Action <$> actionList)+ <|> rangeParser+ <|> (try (DirectChild <$ (char '>' >> whiteSpace) <*> webref) <|> webrexpOp)+ <|> (Str <$> stringLiteral)+ <|> (Ref <$> webref)+ <?> "expterm"+ +spaceSurrounded :: Parsed st a -> Parsed st a+spaceSurrounded p = do+ whiteSpace+ something <- p+ whiteSpace+ return something++-----------------------------------------------+---- Little helpers+-----------------------------------------------+binary :: String -> (a -> a -> a) -> Assoc -> Operator String st Identity a+binary name fun = Infix (do{ reservedOp name; return fun })++prefix :: String -> (a -> a) -> Operator String st Identity a+prefix name fun = Prefix (do{ reservedOp name; return fun })++postfix :: String -> (a -> a) -> Operator String st Identity a+postfix name fun = Postfix (do{ reservedOp name; return fun })+
+ Webrexp/ProjectByteString.hs view
@@ -0,0 +1,6 @@+-- | Re-export module to standardise one byte string module+-- across the project.+module Webrexp.ProjectByteString ( module Data.ByteString.Char8 ) where++import Data.ByteString.Char8+
+ Webrexp/Remote/MimeTypes.hs view
@@ -0,0 +1,129 @@+-- | This module implement helper functions to determine if+-- downloaded URI can be parsed as HTML/XML. Everything+-- is based on MIME-TYPE, or file extension for local content.+module Webrexp.Remote.MimeTypes ( -- * Types+ ContentType+ , ParseableType(..)+ -- * Functions+ , getParserForMimeType + , getParseKind+ , addContentTypeExtension+ ) where++import System.FilePath+import qualified Data.Map as Map++-- | Describe different kind of content parser usable+data ParseableType =+ -- | Indicate a parser which must be tolerant enough+ -- to parse HTML+ ParseableHTML+ -- | You can go ahead and use a rather strict parser.+ | ParseableXML+ -- | Do what you want with it for now.+ | ParseableJson+ deriving Eq++-- | Type alias to ease documentation.+type ContentType = String++-- | Content-type field of HTTP header+findContentTypeOf :: ContentType -> ContentType+findContentTypeOf = fst . break (';' ==)+ +-- | Associate extension to parser, used for local file type+-- recognition.+fileExtension :: Map.Map String ParseableType+fileExtension = Map.fromList+ [('.' : ext, v) | (ext, Just v) <- Map.elems mimeExtension]++-- | Given a MimeType, return the kind of parser to use+-- for the given data.+getParserForMimeType :: ContentType -> Maybe ParseableType+getParserForMimeType ctt = Map.lookup (findContentTypeOf ctt) mimeExtension+ >>= snd++-- | Given a file name, return a ParseableType, explaining+-- the kind of parser to use on the given content.+getParseKind :: FilePath -> Maybe ParseableType+getParseKind f = case Map.lookup (takeExtension f) fileExtension of+ Nothing -> Nothing+ Just s -> Just s++-- | Given a content type, the same as 'isParseable', and+-- a filepath, we add a type extension if the the filepath+-- don't have any.+--+-- The intent is to add a valid extension given a valid+-- MIME-TYPE, to get correct OS behaviour.+addContentTypeExtension :: ContentType -> FilePath -> FilePath+addContentTypeExtension ctype path+ | hasExtension path = path+ | otherwise = case Map.lookup (findContentTypeOf ctype) + mimeExtension of+ Nothing -> path+ Just (s,_) -> path <.> s++-- | Mimetype/extension association.+mimeExtension :: Map.Map String (String, Maybe ParseableType)+mimeExtension = Map.fromList+ [("application/atom+xml", ("xml", Just ParseableXML))+ ,("application/json", ("json", Just ParseableJson))+ ,("application/javascript", ("js", Nothing))+ ,("application/octet-stream", ("dat", Nothing))+ ,("application/ogg", ("ogg", Nothing))+ ,("application/pdf", ("pdf", Nothing))+ ,("application/postscript", ("ps", Nothing))+ ,("application/soap+xml", ("xml", Just ParseableXML))+ ,("application/xhtml+xml", ("xhtml", Just ParseableHTML))+ ,("application/xml-dtd", ("dtd", Nothing))+ ,("application/xml", ("xml", Just ParseableXML))+ ,("application/rss+xml", ("rss", Just ParseableXML))+ ,("application/xslt+xml", ("xslt", Just ParseableXML))+ ,("application/mathml+xml", ("mathml", Just ParseableXML))+ ,("application/zip", ("zip", Nothing))+ ,("audio/mp4", ("mp4", Nothing))+ ,("audio/mpeg", ("mpg", Nothing))+ ,("audio/ogg", ("ogg", Nothing))+ ,("audio/vorbis", ("ogg", Nothing))+ ,("audio/x-ms-wma", ("wma", Nothing))+ ,("audio/x-ms-wax", ("", Nothing))+ ,("audio/vnd.wave", ("wav", Nothing))+ ,("image/gif", ("gif", Nothing))+ ,("image/jpeg", ("jpg", Nothing))+ ,("image/png", ("png", Nothing))+ ,("image/svg+xml", ("svg", Just ParseableXML))+ ,("image/tiff", ("tiff", Nothing))+ ,("image/vnd.microsoft.icon", ("icon", Nothing))+ ,("text/cmd", ("cmd", Nothing))+ ,("text/css", ("css", Nothing))+ ,("text/csv", ("csv", Nothing))+ ,("text/html", ("html", Just ParseableHTML))+ ,("text/javascript", ("js", Nothing))+ ,("text/plain", ("txt", Nothing))+ ,("text/xml", ("xml", Just ParseableXML))+ ,("video/mpeg", ("mpg", Nothing))+ ,("video/mp4", ("mp4", Nothing))+ ,("video/ogg", ("ogm", Nothing))+ ,("video/quicktime", ("mov", Nothing))+ ,("video/webm", ("webm", Nothing))+ ,("video/x-ms-wmv", ("wmv", Nothing))+ ,("application/vnd.oasis.opendocument.text", ("odt", Nothing))+ ,("application/vnd.oasis.opendocument.spreadsheet", ("ods", Nothing))+ ,("application/vnd.oasis.opendocument.presentation", ("odp", Nothing))+ ,("application/vnd.oasis.opendocument.graphics", ("odg", Nothing))+ ,("application/vnd.ms-excel", ("xls", Nothing))+ ,("application/vnd.openxmlformats-officedocument.spreadsheetml.sheet", ("xslx", Nothing))+ ,("application/vnd.ms-powerpoint", ("ppt", Nothing))+ ,("application/vnd.openxmlformats-officedocument.presentationml.presentation", ("pptx", Nothing))+ ,("application/msword", ("doc", Nothing))+ ,("application/vnd.openxmlformats-officedocument.wordprocessingml.document", ("docx", Nothing))+ ,("application/vnd.mozilla.xul+xml", ("xml", Just ParseableXML))+ ,("application/x-dvi", ("dvi", Nothing))+ ,("application/x-latex", ("tex", Nothing))+ ,("application/x-font-ttf", ("ttf", Nothing))+ ,("application/x-shockwave-flash", ("swf", Nothing))+ ,("application/x-rar-compressed", ("rar", Nothing))+ ,("application/x-tar", ("tar", Nothing))+ ]+
+ Webrexp/ResourcePath.hs view
@@ -0,0 +1,104 @@+-- | Module implementing plumbing to get a unified path locator,+-- handling URI & local path. Implement the 'GraphPath' and 'GraphWalker'+-- typeclass with 'HxtNode'+module Webrexp.ResourcePath + ( ResourcePath (..)+ , rezPathToString+ , downloadBinary+ ) where++import Webrexp.GraphWalker+import Control.Applicative+import Control.Monad.IO.Class+import Data.Maybe+import Network.HTTP+import Network.Browser+import Network.URI+import System.Directory+import System.FilePath+import qualified Webrexp.ProjectByteString as B++import Webrexp.Remote.MimeTypes++-- | Main data type+data ResourcePath =+ -- | Represent a file stored on the hard-drive of this+ -- machine.+ Local FilePath+ -- | Represent a ressource spread on internet.+ | Remote URI+ deriving (Eq, Show)++instance GraphPath ResourcePath where+ (<//>) = combinePath+ importPath = toRezPath+ dumpDataAtPath = dumpResourcePath + localizePath = extractFileName++-- | Given a ressource, transforme it to a string+-- representation. This function should be used instead+-- of the 'Show' instance, which is aimed at debugging+-- only.+rezPathToString :: ResourcePath -> String+rezPathToString (Local p) = p+rezPathToString (Remote uri) = show uri++toRezPath :: String -> Maybe ResourcePath+toRezPath s = case (parseURI s, isValid s, isRelativeReference s) of+ (Just u, _, _) -> Just $ Remote u+ (Nothing, True, _) -> Just $ Local s+ (Nothing, False, True) -> Remote <$> parseRelativeReference s+ (Nothing, False, False) -> Nothing++-- | Resource path combiner, similar to </> in use,+-- but also handle URI.+combinePath :: ResourcePath -> ResourcePath -> ResourcePath+combinePath (Local a) (Local b) = Local $ dropFileName a </> b+combinePath (Remote a) (Remote b) =+ case b `relativeTo` a of+ -- TODO : find another way for this+ Nothing -> error "Can't merge resourcepath" + -- Remote a+ Just c -> Remote c++combinePath (Remote a) (Local b)+ | isRelativeReference b = case parseRelativeReference b of+ Just r -> Remote . fromJust $ r `relativeTo` a+ Nothing -> error "Not possible, checked before"+combinePath (Local _) b@(Remote _) = b+combinePath _ _ = error "Mixing local/remote path"++extractFileName :: ResourcePath -> String+extractFileName (Remote a) = snd . splitFileName $ uriPath a+extractFileName (Local c) = snd $ splitFileName c++dumpResourcePath :: (Monad m, MonadIO m)+ => Loggers -> ResourcePath -> m ()+dumpResourcePath _ src@(Local source) = do+ cwd <- liftIO getCurrentDirectory+ liftIO . copyFile source $ cwd </> extractFileName src++dumpResourcePath loggers@(logger,_,_) p@(Remote a) = do+ (_, rsp) <- downloadBinary loggers a+ let rawFilename = extractFileName p+ filename = case retrieveHeaders HdrContentType rsp of+ [] -> rawFilename + (hdr:_) -> addContentTypeExtension+ (hdrValue hdr) rawFilename+ ++ liftIO . logger $ "Downloading '" ++ show a ++ "' in '" ++ filename+ liftIO . B.writeFile filename $ rspBody rsp++-- | Helper function to grab a resource on internet and returning+-- it's binary representation, and it's real place if any.+downloadBinary :: (Monad m, MonadIO m)+ => Loggers -> URI -> m (URI, Response B.ByteString)+downloadBinary (_, errLog, verbose) url =+ liftIO . browse $ do+ setAllowRedirects True+ setErrHandler errLog+ setOutHandler verbose+ request $ defaultGETRequest_ url++
+ Webrexp/UnionNode.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+-- Here be dragons.+{-# LANGUAGE UndecidableInstances #-}++-- | This module has for aim to create new node type by combining+-- different GraphWalkers. The idea is to be able to walk from an+-- XML file to a Json file and so forth.+module Webrexp.UnionNode( PartialGraph( .. ), UnionNode ( .. ) ) where++import Control.Applicative+import Control.Monad.IO.Class+import Network.HTTP+import System.Directory++import Webrexp.GraphWalker+import Webrexp.Remote.MimeTypes+import Webrexp.ResourcePath+import qualified Webrexp.ProjectByteString as B++-- | Extension of GraphWalker class to be able to query the type+-- about it's possibility of parsing. Very ad-hoc.+class (GraphWalker a rezPath) => PartialGraph a rezPath where+ -- | Provide a dummy element just to be passed at 'isResourceParseable'.+ -- Forcing a monoid instance was not ideal, so here is the hack.+ dummyElem :: a++ -- | Tell if a node type can parse a given document, used+ -- in the node type decision.+ isResourceParseable :: a -> rezPath -> ParseableType -> Bool++ -- | The real parsing function.+ parseResource :: rezPath -> ParseableType -> B.ByteString -> Maybe a++-- | Data type which is an instance of graphwalker.+-- Use it to combine two other node types.+data UnionNode a b = UnionLeft a | UnionRight b+ deriving Eq++-- | Allow recursion of union node, so a tree of multidomain+-- node can be built.+instance ( PartialGraph a rezPath+ , PartialGraph b rezPath+ , GraphWalker (UnionNode a b) rezPath)+ => PartialGraph (UnionNode a b) rezPath where+ dummyElem = undefined++ isResourceParseable _ datapath parser =+ isResourceParseable (dummyElem :: a) datapath parser ||+ isResourceParseable (dummyElem :: b) datapath parser++ parseResource datapath parser binData =+ case ( isResourceParseable (dummyElem :: a) datapath parser+ , isResourceParseable (dummyElem :: b) datapath parser) of+ (True, _) -> UnionLeft <$> parseResource datapath parser binData+ (_ , _) -> UnionRight <$> parseResource datapath parser binData++instance (PartialGraph a ResourcePath, PartialGraph b ResourcePath)+ => GraphWalker (UnionNode a b) ResourcePath where++ attribOf att (UnionLeft a) = attribOf att a+ attribOf att (UnionRight a) = attribOf att a++ nameOf (UnionLeft a) = nameOf a+ nameOf (UnionRight a) = nameOf a++ childrenOf (UnionLeft a) =+ childrenOf a >>= \c -> return $ UnionLeft <$> c+ childrenOf (UnionRight a) =+ childrenOf a >>= \c -> return $ UnionRight <$> c++ valueOf (UnionLeft a) = valueOf a+ valueOf (UnionRight a) = valueOf a++ indirectLinks (UnionLeft a) = indirectLinks a+ indirectLinks (UnionRight a) = indirectLinks a++ accessGraph = loadData++ isHistoryMutable (UnionLeft a) = isHistoryMutable a+ isHistoryMutable (UnionRight a) = isHistoryMutable a++parseUnion :: forall a b m.+ ( MonadIO m+ , PartialGraph a ResourcePath+ , PartialGraph b ResourcePath )+ => Maybe ParseableType -> ResourcePath -> B.ByteString+ -> m (AccessResult (UnionNode a b) ResourcePath)+parseUnion Nothing datapath binaryData =+ return $ DataBlob datapath binaryData++parseUnion (Just parser) datapath binaryData =+ let binaryContent = DataBlob datapath binaryData+ in case ( isResourceParseable (dummyElem :: a) datapath parser+ , isResourceParseable (dummyElem :: b) datapath parser ) of+ (True, _) -> maybe (return binaryContent)+ (return . Result datapath . UnionLeft) + $ parseResource datapath parser binaryData+ ( _, True) -> maybe (return binaryContent)+ (return . Result datapath . UnionRight)+ $ parseResource datapath parser binaryData+ _ -> return binaryContent++++loadData :: ( MonadIO m+ , PartialGraph a ResourcePath+ , PartialGraph b ResourcePath )+ => Loggers -> ResourcePath+ -> m (AccessResult (UnionNode a b) ResourcePath)+loadData (logger, _errLog, _verbose) datapath@(Local s) = do+ liftIO . logger $ "Opening file : '" ++ s ++ "'"+ realFile <- liftIO $ doesFileExist s+ if not realFile+ then return AccessError+ else do file <- liftIO $ B.readFile s+ parseUnion (getParseKind s) datapath file++loadData loggers@(logger, _, verbose) (Remote uri) = do+ liftIO . logger $ "Downloading URL : '" ++ show uri ++ "'"+ (u, rsp) <- downloadBinary loggers uri+ let contentType = retrieveHeaders HdrContentType rsp+ binaryData = rspBody rsp+ case contentType of+ [] -> return $ DataBlob (Remote u) binaryData+ (hdr:_) -> do+ liftIO . verbose $ "Downloaded (" ++ show u ++ ") ["+ ++ hdrValue hdr ++ "] "+ parseUnion (getParserForMimeType $ hdrValue hdr)+ (Remote u) binaryData+
+ Webrexp/WebContext.hs view
@@ -0,0 +1,472 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- | This module define the state carryied during the webrexp+-- evaluation. This state is implemented as a monad transformer+-- on top of 'IO'.+module Webrexp.WebContext+ ( + -- * Types+ WebCrawler+ , WebContextT ( .. )+ , WebContext + , NodeContext (..)+ , EvalState (..)+ , BinBlob (..)+ , Context+ , HistoryPath (..)++ -- * Aliases+ -- Only used to provide more meaningful type signatures+ , Counter+ , SeenCounter+ , ValidSeenCounter+ , StateNumber++ -- * Node manipulation function/operators+ , (^:)+ , (^+)++ -- * Crawling configuration+ , LogLevel (..)+ , setLogLevel + , getUserAgent + , setUserAgent + , setOutput + , getOutput+ , getHttpDelay + , setHttpDelay + , isVerbose++ -- * User function+ , evalWithEmptyContext+ , repurposeNode + + -- * Implementation info+ -- ** Evaluation function+ , prepareLogger ++ -- ** State manipulation functions+ , pushCurrentState + , popCurrentState ++ -- * DFS evaluator+ -- ** Node list+ , recordNode + , popLastRecord ++ -- ** Branch context+ , accumulateCurrentState + , popAccumulation ++ , pushToBranchContext + , popBranchContext + , addToBranchContext ++ -- ** Unicity manipulation function+ , setBucketCount + , incrementGetRangeCounter + , hasResourceBeenVisited+ , setResourceVisited+ )+ where++import System.IO+import Control.Applicative+import Control.Arrow( first )+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Data.Functor.Identity+import Data.Array.IO+import qualified Data.Set as Set++import qualified Webrexp.ProjectByteString as B+import Webrexp.GraphWalker++-- | Typical use of the WebContextT monad transformer+-- allowing to download information+type WebCrawler node rezPath a = WebContextT node rezPath IO a++-- | WebContext is 'WebContextT' as a simple Monad+type WebContext node rezPath a = WebContextT node rezPath Identity a++-- | Record a graph path in a document, from the last indirect+-- node to this one.+data HistoryPath node =+ -- | A path in an immutable graph. The graph that+ -- doesn't move under our feets, so we store the+ -- index of the followgin node in the path.+ ImmutableHistory [(node, Int)]++ -- | If the graph is suceptible to move under our+ -- feets, we have to search again for the position+ -- of the node in the parent node.+ | MutableHistory [node]++-- | Fuse two history together, is equivalent to the '++'+-- operator for list.+(^+) :: [(node, Int)] -> HistoryPath node -> HistoryPath node+(^+) nodes (MutableHistory hist) = MutableHistory $ map fst nodes ++ hist+(^+) nodes (ImmutableHistory hist) = ImmutableHistory $ nodes ++ hist++-- | Append at info at the beginning of an history,+-- equivalent to the ':' operator for lists.+(^:) :: (node, Int) -> HistoryPath node -> HistoryPath node+(^:) (node, _) (MutableHistory hist) = MutableHistory $ node : hist+(^:) node (ImmutableHistory hist) = ImmutableHistory $ node : hist++-- | Represent a graph node and the path+-- used to go up to it.+data NodeContext node rezPath = NodeContext+ { -- | Path from the root of the document to+ -- 'this' node.+ parents :: HistoryPath node++ -- | Real node value+ , this :: node ++ -- | The last indirect path used to get to this node.+ , rootRef :: rezPath + }++-- | Function useful if used in combination of an union-node :+-- - A function produce a node context for a specific type+-- - You want to generalise it for a complex union+-- - Use this function :)+--+-- For example to produce a simple union node :+--+-- > repurposeNode UnionRight $ initialSimpleNode+repurposeNode :: (nodeA -> nodeB) -> NodeContext nodeA rezPath+ -> NodeContext nodeB rezPath+repurposeNode f node = NodeContext+ { parents = historyPatcher $ parents node+ , this = f $ this node+ , rootRef = rootRef node+ }+ where historyPatcher (ImmutableHistory hist) =+ ImmutableHistory $ map (first f) hist+ historyPatcher (MutableHistory hist) =+ MutableHistory $ map f hist++-- | Represent a binary blob, often downloaded.+data BinBlob rezPath = BinBlob+ { -- | The last indirect path used to get to this blob.+ sourcePath :: rezPath++ -- | The binary data+ , blobData :: B.ByteString+ }++-- | This type represent the temporary results+-- of the evaluation of regexp.+data EvalState node rezPath =+ Node (NodeContext node rezPath)+ | Text String+ | Blob (BinBlob rezPath)++-- | Type used to represent the current logging level.+-- Default is 'Normal'+data LogLevel = Quiet -- ^ Only display the dumped information+ | Normal -- ^ Display dumped information and IOs+ | Verbose -- ^ Display many debugging information+ deriving (Eq)++-- | An int used as a counter+type Counter = Int++-- | Number of elements seen at a state in the automata.+type SeenCounter = Int++-- | Number of elements which arrived by a true transition+-- to a state in the automata.+type ValidSeenCounter = Int++-- | Just an index to a state in the automata.+type StateNumber = Int++-- | Internal data context.+data Context node rezPath = Context+ { -- | Context stack used in breadth-first evaluation+ contextStack :: [([EvalState node rezPath], Counter)]++ -- | State waiting to be executed in a depth-+ -- first execution.+ , waitingStates :: [(EvalState node rezPath, StateNumber)]++ -- | State used to implement branches in the depth+ -- first evaluator.+ , branchContext :: [(EvalState node rezPath, SeenCounter, ValidSeenCounter)]++ -- | Buckets used for uniqueness pruning, all+ -- evaluation kind.+ , uniqueBucket :: IOArray Int (Set.Set String) ++ -- | Counters used for range evaluation in DFS+ , countBucket :: IOUArray Int Counter++ -- | Current log level+ , logLevel :: LogLevel+ , httpDelay :: Int+ , httpUserAgent :: String+ , defaultOutput :: Handle+ }++--------------------------------------------------+---- Monad definitions+--------------------------------------------------+newtype (Monad m) => WebContextT node rezPath m a =+ WebContextT { runWebContextT :: Context node rezPath+ -> m (a, Context node rezPath ) }++instance (Functor m, Monad m) => Functor (WebContextT node rezPath m) where+ {-# INLINE fmap #-}+ fmap f a = WebContextT $ \c ->+ fmap (first f) $ runWebContextT a c++instance (Functor m, Monad m) => Applicative (WebContextT node rezPath m) where+ pure = return+ (<*>) = ap++instance (Monad m) => Monad (WebContextT node rezPath m) where+ {-# INLINE return #-}+ return a =+ WebContextT $ \c -> return (a, c)++ {-# INLINE (>>=) #-}+ (WebContextT val) >>= f = WebContextT $ \c -> do+ (val', c') <- val c+ runWebContextT (f val') c'++instance MonadTrans (WebContextT node rezPath) where+ lift m = WebContextT $ \c -> do+ a <- m+ return (a, c)++instance (MonadIO m) => MonadIO (WebContextT node rezPath m) where+ liftIO = lift . liftIO++--------------------------------------------------+---- Context manipulation+--------------------------------------------------++emptyContext :: Context node rezPath+emptyContext = Context+ { contextStack = []+ , waitingStates = []+ , branchContext = []+ , logLevel = Normal+ , httpDelay = 1500+ , httpUserAgent = ""+ , defaultOutput = stdout+ , uniqueBucket = undefined+ , countBucket = undefined+ }++--------------------------------------------------+---- Getter/Setter+--------------------------------------------------++-- | Setter for the wait time between two indirect+-- operations.+--+-- The value is stored but not used yet.+setHttpDelay :: (Monad m) => Int -> WebContextT node rezPath m ()+setHttpDelay delay = WebContextT $ \c ->+ return ((), c{ httpDelay = delay })++-- | return the value set by 'setHttpDelay'+getHttpDelay :: (Monad m) => WebContextT node rezPath m Int+getHttpDelay = WebContextT $ \c -> return (httpDelay c, c)++-- | Define the text output for written text.+setOutput :: (Monad m) => Handle -> WebContextT node rezPath m ()+setOutput handle = WebContextT $ \c ->+ return ((), c{ defaultOutput = handle })++-- | Retrieve the default file output used for text.+getOutput :: (Monad m) => WebContextT node rezPath m Handle+getOutput = WebContextT $ \c -> return (defaultOutput c, c)++-- | Set the user agent which must be used for indirect operations+--+-- The value is stored but not used yet.+setUserAgent :: (Monad m) => String -> WebContextT node rezPath m ()+setUserAgent usr = WebContextT $ \c ->+ return ((), c{ httpUserAgent = usr })++-- | return the value set by 'setUserAgent'+getUserAgent :: (Monad m) => WebContextT node rezPath m String+getUserAgent = WebContextT $ \c -> return (httpUserAgent c, c)++-- | Set the value of the logging level.+setLogLevel :: (Monad m) => LogLevel -> WebContextT node rezPath m ()+setLogLevel lvl = WebContextT $ \c ->+ return ((), c{logLevel = lvl})++-- | Tell if the current 'LoggingLevel' is set to 'Verbose'+isVerbose :: (Monad m) => WebContextT node rezPath m Bool+isVerbose = WebContextT $ \c -> + return (logLevel c == Verbose, c)++-- | TODO : write documentation+accumulateCurrentState :: (Monad m)+ => ([EvalState node rezPath], StateNumber)+ -> WebContextT node rezPath m ()+accumulateCurrentState lst = WebContextT $ \c ->+ return ((), c{ contextStack = lst : contextStack c })++-- | TODO : write documentation+popAccumulation :: (Monad m)+ => WebContextT node rezPath m ([EvalState node rezPath], StateNumber)+popAccumulation = WebContextT $ \c ->+ case contextStack c of+ [] -> error "Empty context stack, implementation bug"+ (x:xs) -> return (x, c{ contextStack = xs })++-- | Internally the monad store a stack of state : the list+-- of currently evaluated 'EvalState'. Pushing this context+-- with store all the current nodes in it, waiting for later+-- retrieval.+pushCurrentState :: (Monad m)+ => [EvalState node rezPath]+ -> WebContextT node rezPath m ()+pushCurrentState lst = WebContextT $ \c ->+ return ((), c{ contextStack = (lst, 0) : contextStack c })++-- | Inverse operation of 'pushCurrentState', retrieve+-- stored nodes.+popCurrentState :: (Monad m)+ => WebContextT node rezPath m [EvalState node rezPath]+popCurrentState = WebContextT $ \c ->+ case contextStack c of+ [] -> error "Empty context stack, implementation bug"+ ((x,_):xs) -> + return (x, c{ contextStack = xs })++-- | Helper function used to start the evaluation of a webrexp+-- with a default context, with sane defaults.+evalWithEmptyContext :: (Monad m)+ => WebContextT node rezPath m a -> m a+evalWithEmptyContext val = do+ (finalVal, _context) <- runWebContextT val emptyContext+ return finalVal++-- | Return normal, error, verbose logger+prepareLogger :: (Monad m)+ => WebContextT node rezPath m (Logger, Logger, Logger)+prepareLogger = WebContextT $ \c ->+ let silenceLog _ = return ()+ errLog = hPutStrLn stderr+ normalLog = putStrLn+ in case logLevel c of+ Quiet -> return ((silenceLog, errLog, silenceLog), c)+ Normal -> return ((normalLog, errLog, silenceLog), c)+ Verbose -> return ((normalLog, errLog, normalLog), c)++--------------------------------------------------+---- Depth First evaluation+--------------------------------------------------++-- | Record a node in the context for the DFS evaluation.+recordNode :: (Monad m) + => (EvalState node rezPath, StateNumber) -> WebContextT node rezPath m ()+recordNode n = WebContextT $ \c ->+ return ((), c{ waitingStates = n : waitingStates c })++-- | Get the last record from the top of the stack+popLastRecord :: (Monad m)+ => WebContextT node rezPath m (EvalState node rezPath, StateNumber)+popLastRecord = WebContextT $ \c ->+ case waitingStates c of+ [] -> error "popLAst Record - Empty stack!!!"+ (x:xs) -> return (x, c{ waitingStates = xs })+++-- | Add a \'frame\' context to the current DFS evaluation.+-- A frame context possess a node to revert to and two counters.+--+-- * A counter for seen nodes which must be evaluated before+-- backtracking+--+-- * A counter for valid node count, to keep track if the whole+-- frame has a valid result or not.+--+-- You can look at 'popBranchContext' and 'addToBranchContext'+-- for other frame manipulation functions.+pushToBranchContext :: (Monad m)+ => (EvalState node rezPath, SeenCounter, ValidSeenCounter)+ -> WebContextT node rezPath m ()+pushToBranchContext cont = WebContextT $ \c ->+ return ((), c{ branchContext = cont : branchContext c })++-- | Retrieve the frame on the top of the stack.+-- for more information regarding frames see 'pushToBranchContext'+popBranchContext :: (Monad m)+ => WebContextT node rezPath m (EvalState node rezPath, SeenCounter, ValidSeenCounter)+popBranchContext = WebContextT $ \c ->+ case branchContext c of+ [] -> error "popBranchContext - empty branch context"+ (x:xs) -> return (x, c{ branchContext = xs })++-- | Add seen node count and valid node count to the current+-- frame.+--+-- for more information regarding frames see 'pushToBranchContext'+addToBranchContext :: (Monad m)+ => SeenCounter -> ValidSeenCounter -> WebContextT node rezPath m ()+addToBranchContext count validCount = WebContextT $ \c ->+ case branchContext c of+ [] -> error "addToBranchContext - empty context stack"+ ((e,co,vc):xs) -> return ((), c{ branchContext = (e,co + count+ ,vc + validCount): xs})++--------------------------------------------------+---- Unique bucket+--------------------------------------------------++-- | Initialisation function which must be called before the+-- beginning of a webrexp execution.+--+-- Inform the monad of the number of 'Unique' bucket in the+-- expression, permitting the allocation of the required number+-- of Set to hold them.+setBucketCount :: (Monad m, MonadIO m)+ => Int -- ^ Unique bucket count+ -> Int -- ^ Range counter count+ -> WebContextT node rezPath m ()+setBucketCount uniquecount rangeCount = WebContextT $ \c -> do+ arr <- liftIO $ newArray (0, uniquecount - 1) Set.empty+ counter <- liftIO $ newArray (0, rangeCount - 1) 0+ return ((), c{ uniqueBucket = arr+ , countBucket = counter })++-- | Used for node range, return the current value of the+-- counter and increment it.+incrementGetRangeCounter :: (Monad m, MonadIO m)+ => Int -> WebContextT node rezPath m Int+incrementGetRangeCounter bucket = WebContextT $ \c -> do+ num <- liftIO $ countBucket c `readArray`bucket+ liftIO . (countBucket c `writeArray` bucket) $ num + 1+ return (num, c)++-- | Tell if a string has already been recorded for a bucket ID.+-- Used for the implementation of the 'Unique' constructor of a webrexp.+--+-- Return False, unless 'setResourceVisited' has been called with the same+-- string before.+hasResourceBeenVisited :: (Monad m, MonadIO m)+ => Int -> String -> WebContextT node rezPath m Bool+hasResourceBeenVisited bucketId str = WebContextT $ \c -> do+ set <- liftIO $ uniqueBucket c `readArray`bucketId+ return (str `Set.member` set, c)++-- | Record the visit of a string. 'hasResourceBeenVisited' will return True+-- for the same string after this call.+setResourceVisited :: (Monad m, MonadIO m)+ => Int -> String -> WebContextT node rezPath m ()+setResourceVisited bucketId str = WebContextT $ \c -> do+ set <- liftIO $ uniqueBucket c `readArray` bucketId+ let newSet = str `Set.insert` set+ liftIO $ (uniqueBucket c `writeArray`bucketId) newSet+ return ((), c)+
+ Webrexp/WebRexpAutomata.hs view
@@ -0,0 +1,533 @@+module Webrexp.WebRexpAutomata ( -- * Types+ Automata+ , StateIndex++ -- * Automata manipulation+ , buildAutomata+ , dumpAutomata++ -- * Automata evaluation+ , evalAutomataDFS+ , evalAutomataBFS++ , evalDepthFirst + , evalBreadthFirst + ) where++import Control.Monad+import Data.Array+import qualified Data.Array.Unboxed as U+import System.IO++import Webrexp.Log+import Webrexp.Eval+import Webrexp.GraphWalker+import Webrexp.WebContext+import Webrexp.Exprtypes++type AutomataSink = (Int, Int)++data AutomataAction =+ Push+ | PopPush+ | Pop+ | AutoTrue+ | AutoSimple WebRexp+ | Scatter (U.UArray Int Int)+ | Gather (U.UArray Int Int)+ deriving (Show)+ ++data AutomataState = + -- | Action to perform, action on True+ -- action on False+ AutoState !AutomataAction !Int !Int++-- | The automata representing a WebRexp,+-- ready to be executed.+data Automata = Automata+ { autoStates :: Array Int AutomataState+ , beginState :: Int+ }++type StateListBuilder =+ [(Int, AutomataState)] -> [(Int, AutomataState)]++type FreeId = Int+type FirstState = Int+++-- | Simply the index of the state in a table.+type StateIndex = Int++--------------------------------------------------+---- Automata building+--------------------------------------------------++nodeCount :: Automata -> Int+nodeCount = sizer . bounds . autoStates+ where sizer (low, high) = high - low + 1++-- | General function to translate a webrexp to an evaluation+-- automata.+buildAutomata :: WebRexp -> Automata+buildAutomata expr = Automata+ { beginState = 0+ , autoStates = array (0, lastFree - 1) $ start : end : sts []+ }+ where start = (0, AutoState Push begin begin)+ end = (1, AutoState Pop (-1) (-1))+ (lastFree, begin, sts) = toAutomata expr 2 (1, 1)+++-- | Debug function dumping the automata in form of a+-- graphviz file. The file can be used with the \'dot\'+-- tool to produce a visualisation of the graph.+dumpAutomata :: String -- ^ Text used as title for the automata.+ -> Handle -- ^ Where the graphviz representation will be written.+ -> Automata -- ^ Automata to dump+ -> IO ()+dumpAutomata label h auto = do+ hPutStrLn h $ "// begin:" ++ show (beginState auto)+ ++ " count:" ++ show (nodeCount auto)+ hPutStrLn h "digraph debug {"+ hPutStrLn h $ " graph [fontname=\"Helvetica\", root=\"i" ++ show (beginState auto) + ++ "\" label=\"" ++ concatMap subster label ++ "\"]"+ mapM_ printInfo . assocs $ autoStates auto+ hPutStrLn h "}"+ where printInfo (idx, AutoState act@(Scatter arr) t f) = do+ let idxs = 'i' : show idx+ hPutStrLn h $ idxs ++ " [label=\"" ++ show idx+ ++ " : Scatter\"," ++ shaper act ++ "];"+ dumpLink idxs t f+ dumpAllLinks idxs arr++ printInfo (idx, AutoState act@(Gather arr) t f) = do+ let idxs = 'i' : show idx+ hPutStrLn h $ idxs ++ " [label=\"" ++ show idx+ ++ " : Gather\"," ++ shaper act ++ "];"+ dumpLink idxs t f+ dumpAllLinks idxs arr++ printInfo (idx, AutoState act t f) = do+ let idxs = 'i' : show idx+ hPutStrLn h $ idxs ++ " [label=\"" ++ show idx ++ " : " ++ cleanShow act + ++ "\"," ++ shaper act ++ "];"+ dumpLink idxs t f++ dumpLink idxs t f =+ if t == f && t >= 0+ then hPutStrLn h $ idxs ++ " -> i" ++ show t + ++ "[label=\"t/f\"];"+ else do+ when (t >= 0)+ (hPutStrLn h $ idxs ++ " -> i"+ ++ show t ++ "[label=\"t\"];")+ when (f >= 0)+ (hPutStrLn h $ idxs ++ " -> i"+ ++ show f ++ "[label=\"f\"];")++ cleanShow (AutoSimple DiggLink) = ">>"+ cleanShow (AutoSimple (Unique i)) = '!' : show i+ cleanShow (AutoSimple (Ref ref)) = "<" ++ prettyShowWebRef ref ++ ">"+ cleanShow (AutoSimple (Str str)) = "\\\"" ++ concatMap subster str ++ "\\\""+ cleanShow (AutoSimple (Action _)) = "[ ]"+ cleanShow (AutoSimple (ConstrainedRef ref _)) =+ "<" ++ prettyShowWebRef ref ++ "> []"+ cleanShow a = concatMap subster $ show a++ dumpAllLinks idx arr = mapM_ (\i ->+ hPutStrLn h $ idx ++ " -> i"+ ++ show i ++ "[style=\"dotted\"]"+ ) $ U.elems arr++ shaper (AutoSimple _) = ""+ shaper _ = "shape=\"box\", color=\"yellow\", style=\"filled\""++ subster '"' = "\\\""+ subster '\n' = "\\n"+ subster '\r' = "\\r"+ subster '\\' = "\\\\"+ subster a = [a]++-- | Main transformation function.+-- Assume that each state has two output, one for+-- true and one for false, simplifying the design+-- of the function.+--+-- The idea is to be able to store the automata in an+-- array after the generation, hence the propagation+-- of different indexes.+toAutomata :: WebRexp -- ^ Expression to be transformed into an automata+ -> StateIndex -- ^ Last free index+ -> AutomataSink -- ^ The input/output for the current automata+ -- | The first unused, the index of the beggining state+ -- of the converted webrexp, and finaly the list of states.+ -> (FreeId, FirstState, StateListBuilder) +toAutomata (Unions lst) free (onTrue, onFalse) =+ (contentFree, scatterId, ([scatterState, gatherState] ++) . states)+ where scatterId = free+ gatherId = free + 1++ scatterState = (scatterId, AutoState (Scatter beginList) (head beginIndices) gatherId)+ gatherState = (gatherId, AutoState (Gather beginList) onTrue onFalse)++ beginList = U.listArray (0, length lst - 2) $ tail beginIndices++ transformExprs expr (new, beginIds, st) =+ let (freeId, first, newStates) =+ toAutomata expr new (gatherId, gatherId)+ in (freeId, first : beginIds, newStates . st)++ (contentFree, beginIndices, states) =+ foldr transformExprs (gatherId + 1, [], id) lst++toAutomata (List lst) free (onTrue, onFalse) =+ foldr transformExprs (free, onTrue, id) lst+ where transformExprs expr (new, toTrue, states) =+ let (freeId, first, newStates) =+ toAutomata expr new (toTrue, onFalse)+ in (freeId, first, newStates . states)++toAutomata (Branch []) _ _ =+ error "toAutomata - Empty Branch statement"+toAutomata (Branch (x:lst)) free (onTrue, onFalse) =+ (lastFree, firstSink+ ,firstPush . finalStates . listStates)+ where firstSink = free+ firstPush = ((firstSink, AutoState Push branchBegin branchBegin):)++ -- Code used for the last branch+ transformExprs expr (True, new, (toTrue, toFalse), states) =+ let (freeId, subBegin, newStates) =+ toAutomata expr new (toTrue, toFalse)+ stackChange = ((freeId, AutoState Pop subBegin toFalse):)+ in (False, freeId + 1, (freeId, freeId), stackChange . newStates . states)++ -- all except last and first+ transformExprs expr (_, new, (toTrue, toFalse), states) =+ let (freeId, subBegin, newStates) = toAutomata expr new (toTrue, toFalse)+ stackChange = ((freeId, AutoState PopPush subBegin onFalse):)+ in (False, freeId + 1, (freeId, freeId), stackChange . newStates . states)++ (_, listFree, (listBegin, lastFalseSink), listStates) =+ foldr transformExprs (True, free + 1, (onTrue, onFalse), id) lst++ (lastFree, branchBegin, finalStates) =+ toAutomata x listFree (listBegin, lastFalseSink)++-- For repetition, we simply create a list replicated n times+-- and convert it to an automata+toAutomata (Repeat (RepeatTimes n) expr) free sinks =+ toAutomata (List $ replicate n expr) free sinks+-- For a minimum occurence count, we replicate the minimum+-- and star the maximum.+toAutomata (Repeat (RepeatAtLeast n) expr) free sinks =+ toAutomata (List [List $ replicate n expr+ ,Star expr]) free sinks+-- My favorite...+toAutomata (Repeat (RepeatBetween n m) expr) free (onTrue, onFalse) =+ (minFree, minBegin, states . middleStates)+ where (minFree, minBegin, states) =+ toAutomata (List $ replicate n expr)+ middleFree (middleBegin, onFalse)++ (middleFree, middleBegin, middleStates) =+ toAutomata (List $ replicate (m - n) expr)+ free+ (onTrue, onTrue)++toAutomata (Star expr) free (onTrue, _onFalse) =+ (lastFree, beginning, (trueState :) . states)+ where (lastFree, beginning, states) =+ toAutomata expr (free + 1) (beginning, free)+ trueState =+ (free, AutoState AutoTrue onTrue onTrue)++toAutomata (Alternative a b) free (onTrue, onFalse) =+ (aFree, abeg, aStates . bStates)+ where (bFree, bbeg, bStates) = toAutomata b free (onTrue, onFalse)+ (aFree, abeg, aStates) = toAutomata a bFree (onTrue, bbeg)++-- Like other places in the software, we explicitely list all possibilites+-- to let the compiler help us when refactoring/modifying the types by+-- emitting a warning.+toAutomata rest@(Unique _) free (onTrue, onFalse) =+ (free + 1, free, ((free, AutoState (AutoSimple rest) onTrue onFalse):))+toAutomata rest@(Str _) free (onTrue, onFalse) =+ (free + 1, free, ((free, AutoState (AutoSimple rest) onTrue onFalse):))+toAutomata rest@(Action _) free (onTrue, onFalse) =+ (free + 1, free, ((free, AutoState (AutoSimple rest) onTrue onFalse):))+toAutomata rest@(Range _ _) free (onTrue, onFalse) =+ (free + 1, free, ((free, AutoState (AutoSimple rest) onTrue onFalse):))+toAutomata rest@(Ref _) free (onTrue, onFalse) =+ (free + 1, free, ((free, AutoState (AutoSimple rest) onTrue onFalse):))+toAutomata rest@(DirectChild _) free (onTrue, onFalse) =+ (free + 1, free, ((free, AutoState (AutoSimple rest) onTrue onFalse):))+toAutomata rest@(ConstrainedRef _ _) free (onTrue, onFalse) =+ (free + 1, free, ((free, AutoState (AutoSimple rest) onTrue onFalse):))+toAutomata rest@DiggLink free (onTrue, onFalse) =+ (free + 1, free, ((free, AutoState (AutoSimple rest) onTrue onFalse):))+toAutomata rest@NextSibling free (onTrue, onFalse) =+ (free + 1, free, ((free, AutoState (AutoSimple rest) onTrue onFalse):))+toAutomata rest@PreviousSibling free (onTrue, onFalse) =+ (free + 1, free, ((free, AutoState (AutoSimple rest) onTrue onFalse):))+toAutomata rest@Parent free (onTrue, onFalse) =+ (free + 1, free, ((free, AutoState (AutoSimple rest) onTrue onFalse):))++--------------------------------------------------+---- DFS+--------------------------------------------------++-- | Simple function performing a depth first evaluation+evalDepthFirst :: (GraphWalker node rezPath)+ => EvalState node rezPath -> WebRexp+ -> WebCrawler node rezPath Bool+evalDepthFirst initialState expr = do+ debugLog $ "[Depth first, starting at " ++ show begin ++ "]"+ setBucketCount count rangeCount+ evalAutomataDFS auto (beginState auto) True initialState+ where auto = buildAutomata neorexp+ begin = beginState auto+ (count, rangeCount, neorexp) = assignWebrexpIndices expr++-- | Main Evaluation function+evalAutomataDFS :: (GraphWalker node rezPath)+ => Automata -- ^ Automata to evaluate+ -> StateIndex -- ^ State to evaluate+ -> Bool -- ^ Are we coming from a true link.+ -> EvalState node rezPath -- ^ Current evaluated element+ -> WebCrawler node rezPath Bool+evalAutomataDFS auto i fromTrue e+ | i < 0 = return fromTrue+ | otherwise = do+ debugLog $ "] State " ++ show i+ evalStateDFS auto + (autoStates auto ! i) fromTrue e++-- | Pop a record and start evaluation for him.+scheduleNextElement :: (GraphWalker node rezPath)+ => Automata -> WebCrawler node rezPath Bool+scheduleNextElement a = do+ (e, idx) <- popLastRecord+ evalAutomataDFS a idx True e+++-- | Evaluation function for an element.+evalStateDFS :: (GraphWalker node rezPath)+ => Automata -- ^ Evaluation automata+ -> AutomataState -- ^ Current state in the automata+ -> Bool -- ^ If we are coming from a True link or a False one+ -> EvalState node rezPath -- ^ Currently evaluated element+ -> WebCrawler node rezPath Bool+evalStateDFS a (AutoState (Gather _) onTrue onFalse) valid e = do+ debugLog "> Gather"+ evalAutomataDFS a (if valid then onTrue else onFalse) valid e++evalStateDFS a (AutoState (Scatter idxs) onTrue _) True e = do+ debugLog $ "> Scattering " ++ show (U.bounds idxs)+ mapM_ (\idx -> do debugLog $ " > Scatter " ++ show idx+ recordNode (e, idx)) . reverse $ U.elems idxs+ addToBranchContext (1 + snd (U.bounds idxs)) 0+ evalAutomataDFS a onTrue True e++evalStateDFS a (AutoState (Scatter _) _ onFalse) False e = do+ debugLog "> Scatter FALSE"+ evalAutomataDFS a onFalse False e++evalStateDFS a (AutoState Push onTrue _) _ e = do+ debugLog "> Push"+ pushToBranchContext (e, 1, 0)+ evalAutomataDFS a onTrue True e+ +evalStateDFS a (AutoState AutoTrue onTrue _) _ e = do+ debugLog "> True"+ evalAutomataDFS a onTrue True e++evalStateDFS a (AutoState Pop onTrue onFalse) fromValid _ = do+ debugLog "> Pop"+ (e', left, valid) <- popBranchContext+ let validAdd = if fromValid then 1 else 0+ neoValid = valid + validAdd+ neoCount = left - 1+ if neoCount == 0+ then let nextState = if neoValid > 0 then onTrue else onFalse+ in evalAutomataDFS a nextState (neoValid > 0) e'++ else do pushToBranchContext (e', left - 1, neoValid)+ scheduleNextElement a++ ++evalStateDFS a (AutoState PopPush onTrue onFalse) fromValid _ = do+ debugLog "> PopPush"+ (e', left, valid) <- popBranchContext+ let validAdd = if fromValid then 1 else 0+ neoValid = valid + validAdd+ neoCount = left - 1+ if neoCount == 0+ then if neoValid > 0+ then do pushToBranchContext (e', 1, 0)+ evalAutomataDFS a onTrue True e' + -- we don't push if we failed.+ else evalAutomataDFS a onFalse False e'++ else do pushToBranchContext (e', left - 1, neoValid)+ scheduleNextElement a++evalStateDFS a (AutoState (AutoSimple (Range bucket ranges)) + onTrue onFalse) _ e = do+ count <- incrementGetRangeCounter bucket+ debugLog $ show ranges ++ " - [" ++ show bucket ++ "]" ++ show count ++ " :"+ ++ show (count `isInNodeRange` ranges)+ if count `isInNodeRange` ranges+ then evalAutomataDFS a onTrue True e+ else evalAutomataDFS a onFalse False e++evalStateDFS a (AutoState (AutoSimple rexp) onTrue onFalse) _ e = do+ (valid, subList) <- evalWebRexpFor rexp e+ let nextState = if valid then onTrue else onFalse+ case subList of+ [] -> evalAutomataDFS a onFalse False e+ (x:xs) -> do+ mapM_ (recordNode . flip (,) nextState) $ reverse xs+ addToBranchContext (length xs) 0+ evalAutomataDFS a nextState valid x+++--------------------------------------------------+---- BFS evaluation+--------------------------------------------------++-- | Main function to evaluate the expression in breadth+-- first order.+evalBreadthFirst :: (GraphWalker node rezPath)+ => EvalState node rezPath -> WebRexp+ -> WebCrawler node rezPath Bool+evalBreadthFirst initialState expr = do+ debugLog $ "[Breadth first, starting at " ++ show begin ++ "]"+ setBucketCount count 0+ evalAutomataBFS auto (beginState auto) True [initialState]+ where auto = buildAutomata neorexp+ begin = beginState auto+ (count, _, neorexp) = assignWebrexpIndices expr++evalAutomataBFS :: (GraphWalker node rezPath)+ => Automata -- ^ Automata to evaluate+ -> StateIndex -- ^ State to evaluate+ -> Bool -- ^ Are we coming from a true link.+ -> [EvalState node rezPath] -- ^ Current evaluated element+ -> WebCrawler node rezPath Bool+evalAutomataBFS auto i fromTrue e+ | i < 0 = return fromTrue+ | otherwise = do+ debugLog $ "] State " ++ show i+ evalStateBFS auto + (autoStates auto ! i) fromTrue e+++-- | Main evaluation function for BFS evaluation.+evalStateBFS :: (GraphWalker node rezPath)+ => Automata -- ^ Evaluation automata+ -> AutomataState -- ^ Current state in the automata+ -> Bool -- ^ If we are coming from a True link or a False one+ -> [EvalState node rezPath] -- ^ Currently evaluated elements+ -> WebCrawler node rezPath Bool++evalStateBFS a (AutoState (Gather idxs) onTrue onFalse) valid e = do+ debugLog "> Gather"+ (st, idx) <- popAccumulation+ (beginSt, _) <- popAccumulation+ let (_, maxId) = U.bounds idxs+ toConcat = if valid then e else []+ if idx <= maxId+ then do+ accumulateCurrentState (beginSt, 0)+ accumulateCurrentState (st ++ toConcat, idx + 1)+ evalAutomataBFS a (idxs U.! idx) True beginSt++ else do+ let finalSt = st ++ toConcat+ finalValid = not $ null finalSt+ debugLog $ " > gathered " ++ show (length finalSt)+ evalAutomataBFS a (if finalValid then onTrue else onFalse)+ finalValid finalSt++evalStateBFS a (AutoState (Scatter _) onTrue _) True e = do+ debugLog "> Scatter"+ accumulateCurrentState (e, 0)+ accumulateCurrentState ([], 0)+ evalAutomataBFS a onTrue True e++evalStateBFS a (AutoState (Scatter _) _ onFalse) False e = do+ debugLog "> Scatter FALSE"+ evalAutomataBFS a onFalse False e++evalStateBFS a (AutoState Push onTrue _) True e = do+ debugLog "> Push"+ pushCurrentState e+ evalAutomataBFS a onTrue True e+ +evalStateBFS a (AutoState Push _ onFalse) False e = do+ debugLog "> Push"+ pushCurrentState e+ evalAutomataBFS a onFalse False e++evalStateBFS a (AutoState AutoTrue onTrue _) _ e = do+ debugLog "> True"+ evalAutomataBFS a onTrue True e++evalStateBFS a (AutoState Pop onTrue _) True _ = do+ debugLog "> Pop"+ newList <- popCurrentState+ evalAutomataBFS a onTrue True newList++evalStateBFS a (AutoState Pop _ onFalse) False _ = do+ debugLog "> Pop"+ newList <- popCurrentState+ evalAutomataBFS a onFalse False newList++evalStateBFS a (AutoState PopPush _ onFalse) False _ = do+ debugLog "> PushPop"+ newList <- popCurrentState+ pushCurrentState newList+ evalAutomataBFS a onFalse False newList++evalStateBFS a (AutoState PopPush onTrue _) True _ = do+ debugLog "> PopPush"+ newList <- popCurrentState+ pushCurrentState newList+ evalAutomataBFS a onTrue True newList++evalStateBFS a (AutoState (AutoSimple (Range _ ranges)) + onTrue onFalse) _ e = do+ let nodes = filterNodes ranges e+ nextState = if null nodes then onFalse else onTrue+ evalAutomataBFS a nextState (not $ null nodes) nodes++evalStateBFS a (AutoState (AutoSimple rexp) onTrue onFalse) _ e = do+ e' <- mapM (evalWebRexpFor rexp) e+ let valids = concat [ lst | (v, lst) <- e', v ]+ nextState = if null valids then onFalse else onTrue+ evalAutomataBFS a nextState (not $ null valids) valids++-- | For the current state, filter the value to keep+-- only the values which are included in the node+-- range.+filterNodes :: [NodeRange] -> [a] -> [a]+filterNodes ranges = filtered+ where filtered = discardLockstep ranges . zip [0..]+ discardLockstep [] _ = []+ discardLockstep _ [] = []+ discardLockstep rlist@(Index i:xs) elist@((i2,e):ys)+ | i2 == i = e : discardLockstep xs ys+ | i2 < i = discardLockstep rlist ys+ -- i2 > i (should not arrise in practice)+ | otherwise = discardLockstep xs elist+ discardLockstep rlist@(Interval a b:xs) elist@((i,e):ys)+ | i < a = discardLockstep rlist ys+ -- i >= a+ | i < b = e : discardLockstep rlist ys+ | i == b = e : discardLockstep xs ys+ -- i > b+ | otherwise = discardLockstep xs elist
+ webrexpMain.hs view
@@ -0,0 +1,86 @@++import Control.Monad+import qualified Control.Exception as E+import System.Console.GetOpt+import System.Environment+import System.IO+import System.Exit++import Webrexp++data Flag = Verbose+ | Quiet+ | Input String+ | Output String+ | BfsEval+ | Help+ | Graphviz+ | Delay Int+ deriving Eq++version :: String+version = "1.0"++options :: [OptDescr Flag]+options =+ [ Option "o" ["output"] (ReqArg Output "FILE") "output FILE"+ , Option "f" ["file"] (ReqArg Input "FILE") "input FILE, use - for stdin"+ , Option "v" ["verbose"] (NoArg Verbose) "Display many information"+ , Option "q" ["quiet"] (NoArg Quiet) "Remain practically silent"+ , Option "h" ["help"] (NoArg Help) "Display help (this screen)"+ , Option "d" ["delay"] (ReqArg (Delay . read) "Delay")+ "Time to wait between HTTP request (ms)"+ , Option "" ["bfs"] (NoArg BfsEval)+ "Evaluate in BFS order - This option might not remain in the future"+ , Option "" ["dot"] (NoArg Graphviz)+ "Output the evaluation automata in graphviz format."+ ]++hasInput :: Flag -> Bool+hasInput (Input _) = True+hasInput _ = False++parseArgs :: [String] -> IO Conf+parseArgs args =+ case getOpt Permute options args of+ (opt, [], _) -> do+ conf <- foldM configurator defaultConf opt+ return $ conf { showHelp = not $ any hasInput opt }+ (opt, left:_, _) -> do+ conf <- foldM configurator defaultConf opt+ if expr conf == "" then return $ conf{expr = left}+ else return conf+ where configurator c Verbose = return $ c{ verbose = True }+ configurator c Quiet = return $ c{ quiet = True }+ configurator c Help = return $ c{ showHelp = True }+ configurator c Graphviz = return $ c { outputGraphViz = True }+ configurator c BfsEval = return $ c { depthEvaluation = False }+ configurator c (Output "-") = return $ c { output = stdout }+ configurator c (Delay i) = return $ c { hammeringDelay = i }+ configurator c (Input fname) = do+ file <- readFile fname+ return $ c{ expr = file }+ configurator c (Output fname) = do+ file <- openFile fname WriteMode+ return $ c{ output = file }++mainProgram :: IO ()+mainProgram = do+ args <- getArgs+ c <- parseArgs args+ if showHelp c+ then do putStrLn $ usageInfo ("Webrexp v" ++ version) options+ exitWith ExitSuccess++ else do valid <- evalWebRexpWithConf c+ if valid+ then exitWith ExitSuccess+ else exitWith $ ExitFailure 1++main :: IO ()+main =+ E.catch mainProgram+ (\e -> do+ let err = show (e :: E.AsyncException)+ putStrLn $ "Error : " ++ err+ return ())