From: Michael Orlitzky Date: Tue, 18 Aug 2009 19:58:51 +0000 (-0400) Subject: Initial commit. X-Git-Url: https://gitweb.michael.orlitzky.com/?a=commitdiff_plain;ds=inline;p=dead%2Fhfusk.git Initial commit. --- 70aa0d676da24b89c8dfb8b5077680d993282919 diff --git a/hfusk.hs b/hfusk.hs new file mode 100644 index 0000000..44091df --- /dev/null +++ b/hfusk.hs @@ -0,0 +1,248 @@ +-- +-- hfusk is a Haskell implementation of a "Fusker". For +-- more information, see http://en.wikipedia.org/wiki/Fusker. +-- +-- Copyright Michael Orlitzky +-- +-- http://michael.orlitzky.com/ +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation, either version 3 of the License, or +-- (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- http://www.fsf.org/licensing/licenses/gpl.html +-- +-- +-- Valid patterns involve (possibly nested) combinations of the following: +-- Text : Everything except the patterns below will be used literally. +-- [x-y] : Produces all integers between x and y inclusive. +-- {x,y,z..} : Produces x, y, and z. +-- +-- +-- Examples: +-- +-- hfusk "http://mail[1-3].google.com/" +-- -> "http://mail1.google.com/" +-- -> "http://mail2.google.com/" +-- -> "http://mail3.google.com/" +-- +-- hfusk "http://{mail1,mail2}.google.com/" +-- -> "http://mail1.google.com/" +-- -> "http://mail2.google.com/" +-- + + +import Data.List (nub) +import System.Console.GetOpt +import System.Environment (getArgs) +import System.Exit +import System.IO (hPutStrLn, stderr) +import Text.ParserCombinators.Parsec + + +----------------------- +-- Command-line flags - +----------------------- + +data Flag + = Help -- -h + | Quiet -- -q + deriving (Eq, Ord, Enum, Show, Bounded) + + +-- The list of flags we accept +flags :: [OptDescr Flag] +flags = [ Option ['h'][] (NoArg Help) "Prints this help message.", + Option ['q'][] (NoArg Quiet) "Quiet mode: produce no standard output." ] + + +-- The usage header +usage :: String +usage = "Usage: hfusk [-hq] " + + +-- The usage header, and all available flags (as generated by GetOpt) +help :: String +help = usageInfo usage flags + + +-- Return a list of options and a list of patterns if everything +-- goes well. Otherwise, bail and show the help. +parse_command_line :: [String] -> IO ([Flag], [String]) +parse_command_line argv = + case (getOpt Permute flags argv) of + (options, pattern, []) -> + return (options, pattern) + (_, _, errors) -> do + hPutStrLn stderr (concat errors) + hPutStrLn stderr help + exitFailure + + +----------------------- +-- Cartesian Product -- +----------------------- + +cartesian_product :: [[a]] -> [[a]] -> [[a]] +cartesian_product set1 set2 = + [ concat [x, y] | x <- set1, y <- set2 ] + + +---------------- +-- Parser junk - +---------------- + +data Pattern + = Range (Pattern, Pattern) + | Set [Pattern] + | LiteralInt Integer + | Url String + deriving (Show) + + +class Listable a where + to_list :: a -> [[String]] + + +first_readable_int :: [[String]] -> Integer +first_readable_int x = (read (head (head x))) + +to_integer_range :: Pattern -> Pattern -> [Integer] +to_integer_range x y = + [(first_readable_int (to_list x)) .. (first_readable_int (to_list y))] + + +instance Listable Pattern where + to_list (Range (x, y)) = map (\n -> [show n]) (to_integer_range x y) + to_list (Set x) = concat (map to_list x) + to_list (LiteralInt x) = [[show x]] + to_list (Url x) = [[x]] + + + +-- An integer is one or more digits, as far as I can tell. +int_parser :: Parser Pattern +int_parser = do + val <- many1 digit + return $ LiteralInt (read val) + + +-- Parse a traditional Unix shell-style range, +-- i.e. [1-100] +range_parser :: Parser Pattern +range_parser = do + char '[' + inf <- int_parser + char '-' + sup <- int_parser + char ']' + return $ Range (inf, sup) + + +-- Parse sets of the form {a, b, c..., z} +set_parser :: Parser Pattern +set_parser = do + char '{' + elements <- sepBy1 value_parser set_separator_parser + char '}' + return $ Set elements + + +-- Parse past a comma surrounded by zero or more spaces. +set_separator_parser :: Parser () +set_separator_parser = do + skipMany space + char ',' + skipMany space + + +-- Ad-hoc compilation of characters that I think +-- are valid in URLs +url_characters :: GenParser Char st Char +url_characters = alphaNum <|> + char '.' <|> + char ':' <|> + char '_' <|> + char '-' <|> + char '%' <|> + char '~' <|> + char '?' <|> + char '/' <|> + char '#' <|> + char '&' <|> + char '+' + + +-- Will parse one or more url_characters +url_parser :: Parser Pattern +url_parser = do + val <- many1 url_characters + return $ Url val + + +-- Will parse any of the defined patterns. +value_parser :: Parser Pattern +value_parser = + range_parser <|> + set_parser <|> + url_parser <|> + int_parser + + +-- Uses value_parser to walk the input string, +-- returning the list of parsed Patterns. +main_parser :: Parser [Pattern] +main_parser = do + val <- many1 value_parser + return val + + + +--------- +-- Main - +--------- + +collapse_ast :: [Pattern] -> [String] +collapse_ast ast = + nub (map concat (foldr1 cartesian_product (map to_list ast))) + + +print_list :: Show a => [a] -> IO () +print_list xs = mapM_ (putStrLn . show) xs + + + +main :: IO () +main = do + argv <- getArgs + (options, pattern) <- parse_command_line argv + + -- If the user asked for help, show it and exit successfully. + if (Help `elem` options) + then do + putStrLn help + exitWith ExitSuccess + else return () + + -- If the user didn't supply a pattern we also show the + -- help, but then exit with a failure code. + if (pattern == []) + then do + putStrLn help + exitFailure + else return () + + + case (parse main_parser "" (head pattern)) of + Left err -> do + putStrLn ("Error " ++ (show err)) + exitFailure + Right ast -> do + print_list (collapse_ast ast) + exitWith ExitSuccess diff --git a/makefile b/makefile new file mode 100644 index 0000000..dd824fa --- /dev/null +++ b/makefile @@ -0,0 +1,9 @@ +HFUSK_BIN=hfusk + +hfusk: hfusk.hs + ghc --make -O2 -Wall -o ${HFUSK_BIN} hfusk.hs + +clean: + rm ${HFUSK_BIN} + rm *.hi + rm *.o