diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff --git a/Webrexp.cabal b/Webrexp.cabal new file mode 100644 --- /dev/null +++ b/Webrexp.cabal @@ -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 + diff --git a/Webrexp.hs b/Webrexp.hs new file mode 100644 --- /dev/null +++ b/Webrexp.hs @@ -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 + diff --git a/Webrexp/DirectoryNode.hs b/Webrexp/DirectoryNode.hs new file mode 100644 --- /dev/null +++ b/Webrexp/DirectoryNode.hs @@ -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 + diff --git a/Webrexp/Eval.hs b/Webrexp/Eval.hs new file mode 100644 --- /dev/null +++ b/Webrexp/Eval.hs @@ -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 + diff --git a/Webrexp/Eval/Action.hs b/Webrexp/Eval/Action.hs new file mode 100644 --- /dev/null +++ b/Webrexp/Eval/Action.hs @@ -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) + diff --git a/Webrexp/Eval/ActionFunc.hs b/Webrexp/Eval/ActionFunc.hs new file mode 100644 --- /dev/null +++ b/Webrexp/Eval/ActionFunc.hs @@ -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) + diff --git a/Webrexp/Exprtypes.hs b/Webrexp/Exprtypes.hs new file mode 100644 --- /dev/null +++ b/Webrexp/Exprtypes.hs @@ -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 + diff --git a/Webrexp/GraphWalker.hs b/Webrexp/GraphWalker.hs new file mode 100644 --- /dev/null +++ b/Webrexp/GraphWalker.hs @@ -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 + diff --git a/Webrexp/HaXmlNode.hs b/Webrexp/HaXmlNode.hs new file mode 100644 --- /dev/null +++ b/Webrexp/HaXmlNode.hs @@ -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 + diff --git a/Webrexp/JsonNode.hs b/Webrexp/JsonNode.hs new file mode 100644 --- /dev/null +++ b/Webrexp/JsonNode.hs @@ -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 + diff --git a/Webrexp/Log.hs b/Webrexp/Log.hs new file mode 100644 --- /dev/null +++ b/Webrexp/Log.hs @@ -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 + diff --git a/Webrexp/Parser.hs b/Webrexp/Parser.hs new file mode 100644 --- /dev/null +++ b/Webrexp/Parser.hs @@ -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 }) + diff --git a/Webrexp/ProjectByteString.hs b/Webrexp/ProjectByteString.hs new file mode 100644 --- /dev/null +++ b/Webrexp/ProjectByteString.hs @@ -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 + diff --git a/Webrexp/Remote/MimeTypes.hs b/Webrexp/Remote/MimeTypes.hs new file mode 100644 --- /dev/null +++ b/Webrexp/Remote/MimeTypes.hs @@ -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)) + ] + diff --git a/Webrexp/ResourcePath.hs b/Webrexp/ResourcePath.hs new file mode 100644 --- /dev/null +++ b/Webrexp/ResourcePath.hs @@ -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 + + diff --git a/Webrexp/UnionNode.hs b/Webrexp/UnionNode.hs new file mode 100644 --- /dev/null +++ b/Webrexp/UnionNode.hs @@ -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 + diff --git a/Webrexp/WebContext.hs b/Webrexp/WebContext.hs new file mode 100644 --- /dev/null +++ b/Webrexp/WebContext.hs @@ -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) + diff --git a/Webrexp/WebRexpAutomata.hs b/Webrexp/WebRexpAutomata.hs new file mode 100644 --- /dev/null +++ b/Webrexp/WebRexpAutomata.hs @@ -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 diff --git a/webrexpMain.hs b/webrexpMain.hs new file mode 100644 --- /dev/null +++ b/webrexpMain.hs @@ -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 ())