+--
+-- 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] <pattern>"
+
+
+-- 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
projects / dead / hfusk.git / commitdiff