diff --git a/Text/Webrexp.hs b/Text/Webrexp.hs new file mode 100644 --- /dev/null +++ b/Text/Webrexp.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- | Generic module for using Webrexp as a user. +module Text.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 Text.Webrexp.Exprtypes +import Text.Webrexp.Parser( webRexpParser ) + +import Text.Webrexp.HaXmlNode +import Text.Webrexp.HxtNode +import Text.Webrexp.JsonNode +import Text.Webrexp.UnionNode +import Text.Webrexp.DirectoryNode + +import Text.Webrexp.ResourcePath +import Text.Webrexp.WebContext + +import Text.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 (UnionNode HxtNode 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" ++ show 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) + (do putStrLn $ "code " ++ show (expr 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/Text/Webrexp/DirectoryNode.hs b/Text/Webrexp/DirectoryNode.hs new file mode 100644 --- /dev/null +++ b/Text/Webrexp/DirectoryNode.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Text.Webrexp.DirectoryNode( DirectoryNode + , toDirectoryNode + , currentDirectoryNode + ) where + +import Control.Exception +import Control.Monad.IO.Class +import System.Directory +import System.FilePath + +import Text.Webrexp.GraphWalker +import Text.Webrexp.ResourcePath +import Text.Webrexp.UnionNode +import Text.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 + isResourceParseable _ (Local _) _ = True + isResourceParseable _ _ _ = False + + parseResource _ _ _ _ = return 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 `notElem` [".", ".."]) lst + diff --git a/Text/Webrexp/Eval.hs b/Text/Webrexp/Eval.hs new file mode 100644 --- /dev/null +++ b/Text/Webrexp/Eval.hs @@ -0,0 +1,241 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Text.Webrexp.Eval + ( + -- * Functions + evalAction, + evalWebRexpFor + ) where + +import Control.Applicative +import Control.Monad +import Data.List +import Data.Maybe + +import Text.Webrexp.GraphWalker +import Text.Webrexp.Exprtypes +import Text.Webrexp.WebContext +import Text.Webrexp.Eval.Action +import Text.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, isJust $ attribOf s (this v)] +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 + beenVisited <- visited e + debugLog $ "> '!' (" ++ show bucket ++ ") : visited: " ++ show beenVisited + return (beenVisited, [e]) + where visited (Node n) = do + debugLog $ "> '!' (" ++ show bucket ++ ") : visited: " ++ show (rootRef 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/Text/Webrexp/Eval/Action.hs b/Text/Webrexp/Eval/Action.hs new file mode 100644 --- /dev/null +++ b/Text/Webrexp/Eval/Action.hs @@ -0,0 +1,208 @@ +module Text.Webrexp.Eval.Action( evalAction + , dumpActionVal + , isActionResultValid ) where + +import Control.Applicative +import Control.Monad +import Control.Monad.IO.Class +import Data.List +import Text.Regex.PCRE + +import Text.Webrexp.GraphWalker +import Text.Webrexp.Exprtypes +import Text.Webrexp.WebContext +import Text.Webrexp.Eval.ActionFunc + +import Text.Webrexp.Log +import qualified Text.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) + => Bool -- ^ If we convert recursively data. + -> Maybe (EvalState node rezPath) -- ^ Node to be dumped + -> WebCrawler node rezPath (ActionValue, Maybe (EvalState node rezPath)) +dumpContent _ Nothing = return (ABool False, Nothing) +dumpContent recursive e@(Just (Node ns)) = + case (indirectLinks (this ns), recursive) of + ([], False) -> return (AString $ valueOf (this ns), e) + ([], True) -> (\a -> (AString a, e)) <$> deepValueOf (this ns) + (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 False e +evalAction DeepOutputAction e = dumpContent True 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 (`evalAction` 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 (`evalAction` st) actions + let values = map fst vals + if all (/= ATypeError) values + then f values st + else return (ATypeError, Nothing) + diff --git a/Text/Webrexp/Eval/ActionFunc.hs b/Text/Webrexp/Eval/ActionFunc.hs new file mode 100644 --- /dev/null +++ b/Text/Webrexp/Eval/ActionFunc.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE PatternGuards #-} +module Text.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 Text.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 `elem` " \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/Text/Webrexp/Exprtypes.hs b/Text/Webrexp/Exprtypes.hs new file mode 100644 --- /dev/null +++ b/Text/Webrexp/Exprtypes.hs @@ -0,0 +1,408 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +-- | Datatypes used to describe webrexps, and some helper functions. +module Text.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 ) +import Language.Haskell.TH.Syntax + +-- | 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 + + -- | Translate a node and all it's children into text. + | DeepOutputAction + + -- | 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 + +-------------------------------------------------- +---- Quasi quotation instances +-------------------------------------------------- +instance Lift WebRef where + lift Wildcard = [| Wildcard |] + lift (Elem str) = [| Elem str |] + lift (OfClass ref str) = [| OfClass ref str |] + lift (Attrib ref str) = [| Attrib ref str |] + lift (OfName ref str) = [| OfName ref str |] + +instance Lift NodeRange where + lift (Index i) = [| Index i |] + lift (Interval i1 i2) = [| Interval i1 i2 |] + +instance Lift Op where + lift = return . ConE . mkName . show + +instance Lift BuiltinFunc where + lift = return . ConE . mkName . show + +instance Lift ActionExpr where + lift OutputAction = [| OutputAction |] + lift DeepOutputAction = [| DeepOutputAction |] + lift (ActionExprs lst) = [| ActionExprs lst |] + lift (ARef str) = [| ARef str |] + lift (CstI i) = [| CstI i |] + lift (CstS str) = [| CstS str |] + lift (NodeReplace a) = [| NodeReplace a |] + lift (Call b lst) = [| Call b lst |] + lift (BinOp op a1 a2) = [| BinOp op a1 a2 |] + +instance Lift RepeatCount where + lift (RepeatTimes i) = [| RepeatTimes i |] + lift (RepeatAtLeast i) = [| RepeatAtLeast i |] + lift (RepeatBetween i1 i2) = [| RepeatBetween i1 i2 |] + +instance Lift WebRexp where + lift (Branch lst) = [| Branch lst |] + lift (Unions lst) = [| Unions lst |] + lift (List lst) = [| List lst |] + lift (Star w) = [| Star w |] + lift (Repeat count w) = [| Repeat count w |] + lift (Alternative w1 w2) = [| Alternative w1 w2 |] + lift (Unique i) = [| Unique i |] + lift (Str i) = [| Str i |] + lift (Action a) = [| Action a |] + lift (Range i lst) = [| Range i lst |] + lift (Ref ref) = [| Ref ref |] + lift (DirectChild ref) = [| DirectChild ref |] + lift (ConstrainedRef ref action) = [| ConstrainedRef ref action |] + lift a = return . ConE . mkName $ show a diff --git a/Text/Webrexp/GraphWalker.hs b/Text/Webrexp/GraphWalker.hs new file mode 100644 --- /dev/null +++ b/Text/Webrexp/GraphWalker.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +-- | This module store the interface between the evaluator +-- and the manipulated graph. +module Text.Webrexp.GraphWalker + ( + -- * Classes + GraphWalker(..) + , GraphPath(..) + + -- * Commodity types + , AccessResult(..) + , Logger + , Loggers + , NodePath + + -- * Helper functions. + , descendants + , findNamed + , findFirstNamed + + -- * Helper functions without monadic interface. + , pureDescendants + , findNamedPure + , findFirstNamedPure + ) where + +import Control.Applicative +import Control.Monad.IO.Class +import qualified Text.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 but deepValueOf. +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, Functor 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 + + -- | Like value of, but force the node to collect the + -- value of all it's children in the process. + deepValueOf :: (MonadIO m, Functor m) => a -> m String + deepValueOf node = (valueOf node ++) <$> childrenText + where childrenText = concat <$> (childrenOf node >>= mapM deepValueOf) + +-- | 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 + +-- | like `descendants`, but without the monadic interface. +pureDescendants :: (a -> [a]) -> a -> [(a, [(a, Int)])] +pureDescendants pureChildren node = findDescendants (node, []) + where findDescendants (a, hist) = + let lst = [ (child, (a,idx) : hist) + | (child, idx) <- zip (pureChildren a) [0..]] + in concat $ lst : map findDescendants lst + +-- | Like `findNamed` but without the monadic interface. +findNamedPure :: (GraphWalker a r) + => (a -> [a]) -> String -> a -> [(a, [(a,Int)])] +findNamedPure pureChildren name node = if nameOf node == Just name + then ((node, []) :) validChildren + else validChildren + where validChildren = filter (\(c, _) -> nameOf c == Just name) + $ pureDescendants pureChildren node + +-- | Like `findFirstNamed`, but without the monadic interface. +findFirstNamedPure :: (GraphWalker a r) + => (a -> [a]) -> String -> [a] -> Maybe (a, [(a,Int)]) +findFirstNamedPure pureChildren name lst = + case concatMap (findNamedPure pureChildren name) lst of + [] -> Nothing + (x:_) -> Just x diff --git a/Text/Webrexp/HaXmlNode.hs b/Text/Webrexp/HaXmlNode.hs new file mode 100644 --- /dev/null +++ b/Text/Webrexp/HaXmlNode.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Text.Webrexp.HaXmlNode( HaXmLNode ) where + +import Control.Applicative +import Control.Monad.IO.Class +import Data.Maybe( catMaybes ) +import Data.List( find ) +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 Text.Webrexp.ProjectByteString as B + +import Text.Webrexp.GraphWalker +import Text.Webrexp.ResourcePath +import Text.Webrexp.Remote.MimeTypes +import Text.Webrexp.UnionNode + +type HaXmLNode = Content Posn + +instance PartialGraph HaXmLNode ResourcePath where + isResourceParseable _ _ ParseableXML = True + isResourceParseable _ _ _ = False + + parseResource _ _ ParseableXML bindata = + case xmlParse' "" $ B.unpack bindata of + Left _ -> return Nothing + Right (Document _prolog _ e _) -> return . Just $ CElem e noPos + parseResource _ _ _ _ = error "Cannot parse" + +haxmlNameToString :: QName -> String +haxmlNameToString (N n) = n +haxmlNameToString (QN _ n) = n + +instance GraphWalker HaXmLNode ResourcePath where + accessGraph = loadHtml + + + attribOf attrName (CElem (Elem _ attrList _) _) = + show . snd <$> find nameFinder attrList + where nameFinder (n,_) = haxmlNameToString n == attrName + attribOf _ _ = Nothing + + childrenOf = return . pureChildren + + nameOf (CElem (Elem n _ _) _) = Just $ haxmlNameToString 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/Text/Webrexp/HxtNode.hs b/Text/Webrexp/HxtNode.hs new file mode 100644 --- /dev/null +++ b/Text/Webrexp/HxtNode.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | This module implement the GraphWalker type class +-- for node of HxT (Haskell Xml parser). +module Text.Webrexp.HxtNode ( HxtNode ) where + +import Control.Monad.IO.Class +import Data.Maybe +import Data.Tree.NTree.TypeDefs +import Network.HTTP +import Network.URI +import System.Directory +import Text.XML.HXT.DOM.TypeDefs +import Text.XML.HXT.Parser.HtmlParsec + +import qualified Text.Webrexp.ProjectByteString as B + +import Text.Webrexp.GraphWalker +import Text.Webrexp.ResourcePath +import Text.Webrexp.Remote.MimeTypes +import Text.Webrexp.UnionNode + +-- | This type is an instance of 'GraphWalker' +-- with 'ResourcePath' as 'GraphPath' +type HxtNode = NTree XNode + +instance PartialGraph HxtNode ResourcePath where + isResourceParseable _ _ ParseableHTML = True + isResourceParseable _ _ _ = False + + parseResource _ _ ParseableHTML bindata = + return . Just . parseToHTMLNode $ B.unpack bindata + parseResource _ _ _ _ = error "Cannot parse" + + +instance GraphWalker HxtNode ResourcePath where + deepValueOf = return . deepValue + isHistoryMutable _ = False + accessGraph = loadHtml + attribOf = findAttribute + childrenOf = return . findChildren + valueOf = valueOfNode + nameOf = getName + indirectLinks = hyperNode + +deepValue :: HxtNode -> String +deepValue (NTree (XText txt) _) = txt +deepValue a = concatMap deepValue $ findChildren a + +valueOfNode :: HxtNode -> String +valueOfNode (NTree (XText txt) _) = txt +valueOfNode a = + case findChildren a of + (NTree (XText txt) _:_) -> txt + _ -> "" + +extractText :: [HxtNode] -> String +extractText = concatMap valueOfNode + +findAttribute :: String -> HxtNode -> Maybe String +findAttribute attrName (NTree (XTag _ attrList) _) = + attrFinder attrList + where attrFinder [] = Nothing + attrFinder (NTree (XAttr name) values:_) + | localPart name == attrName = Just $ extractText values + attrFinder (_:xs) = attrFinder xs +findAttribute _ _ = Nothing + +hyperNode :: HxtNode -> [ResourcePath] +hyperNode n = catMaybes [ attribOf "href" n >>= importPath + , attribOf "src" n >>= importPath] + +findChildren :: HxtNode -> [HxtNode] +findChildren (NTree (XTag _ _) children) = children +findChildren _ = [] + +getName :: HxtNode -> Maybe String +getName (NTree (XTag name _) _) = Just $ localPart name +getName _ = Nothing + +parseToHTMLNode :: String -> HxtNode +parseToHTMLNode txt = case findFirstNamedPure findChildren "html" nodes of + Nothing -> NTree (XTag (mkName "html") []) nodes + Just (d, _) -> d + where nodes = parseHtmlContent txt + +parserOfKind :: Maybe ParseableType + -> ResourcePath + -> B.ByteString -> AccessResult HxtNode ResourcePath +parserOfKind (Just ParseableHTML) datapath = + Result datapath . parseToHTMLNode . B.unpack +parserOfKind _ datapath = DataBlob datapath + +-- | Given a resource path, do the required loading +loadHtml :: (MonadIO m) + => Loggers -> ResourcePath + -> m (AccessResult HxtNode ResourcePath) +loadHtml (logger, _errLog, _verbose) (Local s) = do + liftIO . logger $ "Opening file : '" ++ s ++ "'" + realFile <- liftIO $ doesFileExist s + if not realFile + then return AccessError + else do file <- liftIO $ readFile s + return . Result (Local s) + $ parseToHTMLNode 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/Text/Webrexp/JsonNode.hs b/Text/Webrexp/JsonNode.hs new file mode 100644 --- /dev/null +++ b/Text/Webrexp/JsonNode.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Text.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 Text.Webrexp.ProjectByteString as B + +import Text.Webrexp.GraphWalker +import Text.Webrexp.ResourcePath +import Text.Webrexp.UnionNode +import Text.Webrexp.Remote.MimeTypes + +type JsonNode = (Maybe String, JSValue) + +instance PartialGraph JsonNode ResourcePath where + isResourceParseable _ _ ParseableJson = True + isResourceParseable _ _ _ = False + + parseResource _ _ ParseableJson binData = return $ (,) 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/Text/Webrexp/Log.hs b/Text/Webrexp/Log.hs new file mode 100644 --- /dev/null +++ b/Text/Webrexp/Log.hs @@ -0,0 +1,35 @@ + +-- | Implementation of the (rather basic) logging facility. +-- +-- Avoid using 'putStrLn' or 'putStr' in the project, favor +-- using this module. +module Text.Webrexp.Log ( + debugLog + , textOutput + ) where + +import System.IO +import Control.Exception( IOException ) +import qualified Control.Exception as Ex +import Control.Monad +import Control.Monad.IO.Class +import Text.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 $ Ex.catch (hPutStr handle str) + (\e -> hPutStrLn stderr $ "Writing error : " ++ + show (e :: IOException)) + diff --git a/Text/Webrexp/Parser.hs b/Text/Webrexp/Parser.hs new file mode 100644 --- /dev/null +++ b/Text/Webrexp/Parser.hs @@ -0,0 +1,261 @@ +-- | Module implementing the parsing of webrexp. +-- It shouldn't be used directly. +module Text.Webrexp.Parser( webRexpParser ) where + +import Control.Applicative( (<$>), (<$), (<*>) ) +import Control.Monad.Identity +import qualified Data.Map as Map + +import Text.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 '.') + <|> (DeepOutputAction <$ 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/Text/Webrexp/ProjectByteString.hs b/Text/Webrexp/ProjectByteString.hs new file mode 100644 --- /dev/null +++ b/Text/Webrexp/ProjectByteString.hs @@ -0,0 +1,6 @@ +-- | Re-export module to standardise one byte string module +-- across the project. +module Text.Webrexp.ProjectByteString ( module Data.ByteString.Char8 ) where + +import Data.ByteString.Char8 + diff --git a/Text/Webrexp/Quote.hs b/Text/Webrexp/Quote.hs new file mode 100644 --- /dev/null +++ b/Text/Webrexp/Quote.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE FlexibleInstances #-} +module Text.Webrexp.Quote ( webrexpParse + , webrexpCompile ) where + +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import Language.Haskell.TH.Syntax + +import Text.Webrexp +import Text.Webrexp.WebRexpAutomata + +-- | QuasiQuotation to transform a wabrexp to +-- it's AST representation, resulting type is +-- :: WebRexp +webrexpParse :: QuasiQuoter +webrexpParse = QuasiQuoter + { quoteExp = parser + , quotePat = undefined + , quoteType = undefined + , quoteDec = undefined + } + +parser :: String -> Q Exp +parser s = case parseWebRexp s of + Nothing -> fail "Invalid webrexp syntax" + Just w -> lift w + +webrexpCompile :: QuasiQuoter +webrexpCompile = QuasiQuoter + { quoteExp = compiler + , quotePat = undefined + , quoteType = undefined + , quoteDec = undefined + } + +-- | Transform a webrexp to it's \'compiled\' +-- form, resulting type is :: Automata +compiler :: String -> Q Exp +compiler s = case parseWebRexp s of + Nothing -> fail "Invalid webrexp syntax" + Just w -> lift $ buildAutomata w + diff --git a/Text/Webrexp/Remote/MimeTypes.hs b/Text/Webrexp/Remote/MimeTypes.hs new file mode 100644 --- /dev/null +++ b/Text/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 Text.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, Show) + +-- | 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/Text/Webrexp/ResourcePath.hs b/Text/Webrexp/ResourcePath.hs new file mode 100644 --- /dev/null +++ b/Text/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 Text.Webrexp.ResourcePath + ( ResourcePath (..) + , rezPathToString + , downloadBinary + ) where + +import Text.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 Text.Webrexp.ProjectByteString as B + +import Text.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 $ normalise 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 . normalise $ 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/Text/Webrexp/UnionNode.hs b/Text/Webrexp/UnionNode.hs new file mode 100644 --- /dev/null +++ b/Text/Webrexp/UnionNode.hs @@ -0,0 +1,140 @@ +{-# 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 Text.Webrexp.UnionNode( PartialGraph( .. ), UnionNode ( .. ) ) where + +import Control.Applicative +import Control.Monad.IO.Class +import Network.HTTP +import System.Directory + +import Text.Webrexp.GraphWalker +import Text.Webrexp.Remote.MimeTypes +import Text.Webrexp.ResourcePath +import qualified Text.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 + -- | Tell if a node type can parse a given document, used + -- in the node type decision. The first argument has to be + -- ignored, so you can pass 'undefined' to it. + isResourceParseable :: a -> rezPath -> ParseableType -> Bool + + -- | The real parsing function. + -- The IO monad is only here to provide a way to log information + -- TODO : find a better way. + parseResource :: (MonadIO m) + => Loggers -> rezPath -> ParseableType -> B.ByteString -> m (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 + isResourceParseable _ datapath parser = + isResourceParseable (undefined :: a) datapath parser || + isResourceParseable (undefined :: b) datapath parser + + parseResource loggers datapath parser binData = + case ( isResourceParseable (undefined :: a) datapath parser + , isResourceParseable (undefined :: b) datapath parser) of + (True, _) -> parseResource loggers datapath parser binData >>= (\a -> return $ UnionLeft <$> a) + (_ , _) -> parseResource loggers datapath parser binData >>= (\a -> return $ UnionRight <$> a) + +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 + + deepValueOf (UnionLeft a) = deepValueOf a + deepValueOf (UnionRight a) = deepValueOf a + +parseUnion :: forall a b m. + ( MonadIO m, Functor m + , PartialGraph a ResourcePath + , PartialGraph b ResourcePath ) + => Loggers -> Maybe ParseableType -> ResourcePath -> B.ByteString + -> m (AccessResult (UnionNode a b) ResourcePath) +parseUnion _ Nothing datapath binaryData = + return $ DataBlob datapath binaryData + +parseUnion loggers (Just parser) datapath binaryData = + let binaryContent = DataBlob datapath binaryData + in case ( isResourceParseable (undefined :: a) datapath parser + , isResourceParseable (undefined :: b) datapath parser ) of + (True, _) -> + maybe binaryContent + (Result datapath . UnionLeft) <$> parseResource loggers datapath parser binaryData + + ( _, True) -> maybe binaryContent + (Result datapath . UnionRight) + <$> parseResource loggers datapath parser binaryData + _ -> return binaryContent + + + +loadData :: ( MonadIO m, Functor m + , PartialGraph a ResourcePath + , PartialGraph b ResourcePath ) + => Loggers -> ResourcePath + -> m (AccessResult (UnionNode a b) ResourcePath) +loadData loggers@(logger, _errLog, verbose) datapath@(Local s) = do + liftIO . logger $ "Opening file : '" ++ s ++ "'" + realFile <- liftIO $ doesFileExist s + if not realFile + then do + liftIO . verbose $ "Unable to open file : " ++ s + return AccessError + else do file <- liftIO $ B.readFile s + let kind = getParseKind s + liftIO . verbose $ "Found kind " ++ show kind ++ " for (" ++ s ++ ")" + parseUnion loggers kind 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 loggers + (getParserForMimeType $ hdrValue hdr) + (Remote u) binaryData + diff --git a/Text/Webrexp/WebContext.hs b/Text/Webrexp/WebContext.hs new file mode 100644 --- /dev/null +++ b/Text/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 Text.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 Text.Webrexp.ProjectByteString as B +import Text.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/Text/Webrexp/WebRexpAutomata.hs b/Text/Webrexp/WebRexpAutomata.hs new file mode 100644 --- /dev/null +++ b/Text/Webrexp/WebRexpAutomata.hs @@ -0,0 +1,563 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +module Text.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 Text.Webrexp.Log +import Text.Webrexp.Eval +import Text.Webrexp.GraphWalker +import Text.Webrexp.WebContext +import Text.Webrexp.Exprtypes + +import Language.Haskell.TH.Syntax + +type AutomataSink = (Int, Int) + +data AutomataAction = + Push + | PopPush + | Pop + | AutoTrue + | AutoSimple WebRexp + | Scatter (U.UArray Int Int) + | Gather (U.UArray Int Int) + deriving (Show) + +instance Lift AutomataAction where + lift Push = [| Push |] + lift PopPush = [| PopPush |] + lift Pop = [| Pop |] + lift AutoTrue = [| AutoTrue |] + lift (AutoSimple w) = [| AutoSimple w |] + lift (Scatter a) = + [| Scatter $ U.listArray arrayBound elemList |] + where elemList = U.elems a + arrayBound = U.bounds a + lift (Gather a) = + [| Gather $ U.listArray arrayBound elemList |] + where elemList = U.elems a + arrayBound = U.bounds a + +instance Lift AutomataState where + lift (AutoState act i1 i2) = + [| AutoState act i1 i2 |] + +instance Lift Automata where + lift a = [| Automata { autoStates = + listArray stateBound states + , beginState = beginIdx } |] + where beginIdx = beginState a + stateBound = bounds $ autoStates a + states = elems $ autoStates a + +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/Webrexp.cabal b/Webrexp.cabal --- a/Webrexp.cabal +++ b/Webrexp.cabal @@ -1,76 +1,82 @@ -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 - +Name: Webrexp +Version: 1.1 +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.4 && < 0.4.1, + array >= 0.3.0.2 && < 0.3.0.3, + regex-pcre-builtin >= 0.94, + HaXml >= 1.22.5 && < 1.23, + hxt >= 9.1.2 && < 9.2, + AttoJson >= 0.5.1 && < 1.0, + process >= 1.0.1.3 && < 1.1, + filepath >= 1.2.0 && < 1.3, + template-haskell + -- Webrexp + + +Library + Ghc-Options: -Wall + Exposed-Modules: Text.Webrexp, + Text.Webrexp.Parser, + Text.Webrexp.Eval, + Text.Webrexp.Exprtypes, + Text.Webrexp.GraphWalker, + Text.Webrexp.ResourcePath, + Text.Webrexp.Quote + + Other-Modules: + Text.Webrexp.DirectoryNode + Text.Webrexp.Eval.Action + Text.Webrexp.Eval.ActionFunc + Text.Webrexp.HaXmlNode + Text.Webrexp.HxtNode + Text.Webrexp.JsonNode + Text.Webrexp.Log + Text.Webrexp.ProjectByteString + Text.Webrexp.Remote.MimeTypes + Text.Webrexp.UnionNode + Text.Webrexp.WebContext + Text.Webrexp.WebRexpAutomata + + Build-Depends: base >= 2.0 && < 5.0, mtl, + HTTP >= 4000.1.1 && < 4000.2, + HaXml >= 1.22.5 && < 1.23, + hxt >= 9.1.2 && < 9.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.4 && < 0.4.1, + array >= 0.3.0.2 && < 0.3.0.3, + regex-pcre-builtin >= 0.94, + AttoJson >= 0.5.1 && < 1.0, + process >= 1.0.1.3 && < 1.1, + filepath >= 1.2.0 && < 1.3, + template-haskell + diff --git a/Webrexp.hs b/Webrexp.hs deleted file mode 100644 --- a/Webrexp.hs +++ /dev/null @@ -1,144 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/Webrexp/DirectoryNode.hs +++ /dev/null @@ -1,124 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/Webrexp/Eval.hs +++ /dev/null @@ -1,238 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/Webrexp/Eval/Action.hs +++ /dev/null @@ -1,205 +0,0 @@ -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 deleted file mode 100644 --- a/Webrexp/Eval/ActionFunc.hs +++ /dev/null @@ -1,169 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/Webrexp/Exprtypes.hs +++ /dev/null @@ -1,351 +0,0 @@ --- | 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 deleted file mode 100644 --- a/Webrexp/GraphWalker.hs +++ /dev/null @@ -1,152 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/Webrexp/HaXmlNode.hs +++ /dev/null @@ -1,108 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/Webrexp/JsonNode.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/Webrexp/Log.hs +++ /dev/null @@ -1,31 +0,0 @@ - --- | 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 deleted file mode 100644 --- a/Webrexp/Parser.hs +++ /dev/null @@ -1,260 +0,0 @@ --- | 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 deleted file mode 100644 --- a/Webrexp/ProjectByteString.hs +++ /dev/null @@ -1,6 +0,0 @@ --- | 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 deleted file mode 100644 --- a/Webrexp/Remote/MimeTypes.hs +++ /dev/null @@ -1,129 +0,0 @@ --- | 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 deleted file mode 100644 --- a/Webrexp/ResourcePath.hs +++ /dev/null @@ -1,104 +0,0 @@ --- | 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 deleted file mode 100644 --- a/Webrexp/UnionNode.hs +++ /dev/null @@ -1,133 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/Webrexp/WebContext.hs +++ /dev/null @@ -1,472 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/Webrexp/WebRexpAutomata.hs +++ /dev/null @@ -1,533 +0,0 @@ -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 --- a/webrexpMain.hs +++ b/webrexpMain.hs @@ -1,86 +1,87 @@ - -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 ()) + +import Control.Monad +import qualified Control.Exception as E +import System.Console.GetOpt +import System.Environment +import System.IO +import System.Exit + +import Text.Webrexp +import Text.Webrexp.Quote() + +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 ())