hfusk.hs

   1 --
   2 -- hfusk is a Haskell implementation of a "Fusker". For
   3 -- more information, see http://en.wikipedia.org/wiki/Fusker.
   4 --
   5 -- Copyright Michael Orlitzky
   6 --
   7 -- http://michael.orlitzky.com/
   8 --
   9 -- This program is free software: you can redistribute it and/or modify
  10 -- it under the terms of the GNU General Public License as published by
  11 -- the Free Software Foundation, either version 3 of the License, or
  12 -- (at your option) any later version.
  13 --
  14 -- This program is distributed in the hope that it will be useful,
  15 -- but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  17 -- GNU General Public License for more details.
  18 --
  19 -- http://www.fsf.org/licensing/licenses/gpl.html
  20 --
  21 --
  22 -- Valid patterns involve (possibly nested) combinations of the following:
  23 -- Text      : Everything except the patterns below will be used literally.
  24 -- [x-y]     : Produces all integers between x and y inclusive.
  25 -- {x,y,z..} : Produces x, y, and z.
  26 --
  27 --
  28 -- Examples:
  29 --
  30 -- hfusk "http://mail[1-3].google.com/"
  31 -- -> "http://mail1.google.com/"
  32 -- -> "http://mail2.google.com/"
  33 -- -> "http://mail3.google.com/"
  34 --
  35 -- hfusk "http://{mail1,mail2}.google.com/"
  36 -- -> "http://mail1.google.com/"
  37 -- -> "http://mail2.google.com/"
  38 --
  39
  40
  41 import Data.List (nub)
  42 import System.Console.GetOpt
  43 import System.Environment (getArgs)
  44 import System.Exit
  45 import System.IO (hPutStrLn, stderr)
  46 import Text.ParserCombinators.Parsec
  47
  48
  49 -----------------------
  50 -- Command-line flags -
  51 -----------------------
  52
  53 data Flag
  54     = Help -- -h
  55     | Quiet -- -q
  56     deriving (Eq, Ord, Enum, Show, Bounded)
  57
  58
  59 -- The list of flags we accept
  60 flags :: [OptDescr Flag]
  61 flags = [ Option ['h'][] (NoArg Help) "Prints this help message.",
  62           Option ['q'][] (NoArg Quiet) "Quiet mode: produce no standard output." ]
  63
  64
  65 -- The usage header
  66 usage :: String
  67 usage = "Usage: hfusk [-hq] <pattern>"
  68
  69
  70 -- The usage header, and all available flags (as generated by GetOpt)
  71 help :: String
  72 help = usageInfo usage flags
  73
  74
  75 -- Return a list of options and a list of patterns if everything
  76 -- goes well. Otherwise, bail and show the help.
  77 parse_command_line :: [String] -> IO ([Flag], [String])
  78 parse_command_line argv =
  79     case (getOpt Permute flags argv) of
  80     (options, pattern, []) ->
  81         return (options, pattern)
  82     (_, _, errors) -> do
  83          hPutStrLn stderr (concat errors)
  84          hPutStrLn stderr help
  85          exitFailure
  86
  87
  88 -----------------------
  89 -- Cartesian Product --
  90 -----------------------
  91
  92 cartesian_product :: [[a]] -> [[a]] -> [[a]]
  93 cartesian_product set1 set2 =
  94     [ concat [x, y] | x <- set1, y <- set2 ]
  95
  96
  97 ----------------
  98 -- Parser junk -
  99 ----------------
 100
 101 data Pattern
 102     = Range (Pattern, Pattern)
 103     | Set [Pattern]
 104     | LiteralInt Integer
 105     | Url String
 106       deriving (Show)
 107
 108
 109 class Listable a where
 110   to_list :: a -> [[String]]
 111
 112
 113 first_readable_int :: [[String]] -> Integer
 114 first_readable_int x = (read (head (head  x)))
 115
 116 to_integer_range :: Pattern -> Pattern -> [Integer]
 117 to_integer_range x y =
 118   [(first_readable_int (to_list x)) .. (first_readable_int (to_list y))]
 119
 120
 121 instance Listable Pattern where
 122   to_list (Range (x, y)) = map (\n -> [show n]) (to_integer_range x y)
 123   to_list (Set x) = concat (map to_list x)
 124   to_list (LiteralInt x) = [[show x]]
 125   to_list (Url x) = [[x]]
 126
 127
 128
 129 -- An integer is one or more digits, as far as I can tell.
 130 int_parser :: Parser Pattern
 131 int_parser = do
 132   val <- many1 digit
 133   return $ LiteralInt (read val)
 134
 135
 136 -- Parse a traditional Unix shell-style range,
 137 -- i.e. [1-100]
 138 range_parser :: Parser Pattern
 139 range_parser = do
 140   char '['
 141   inf <- int_parser
 142   char '-'
 143   sup <- int_parser
 144   char ']'
 145   return $ Range (inf, sup)
 146
 147
 148 -- Parse sets of the form {a, b, c..., z}
 149 set_parser :: Parser Pattern
 150 set_parser = do
 151   char '{'
 152   elements <- sepBy1 value_parser set_separator_parser
 153   char '}'
 154   return $ Set elements
 155
 156
 157 -- Parse past a comma surrounded by zero or more spaces.
 158 set_separator_parser :: Parser ()
 159 set_separator_parser = do
 160   skipMany space
 161   char ','
 162   skipMany space
 163
 164
 165 -- Ad-hoc compilation of characters that I think
 166 -- are valid in URLs
 167 url_characters :: GenParser Char st Char
 168 url_characters = alphaNum <|>
 169                  char '.' <|>
 170                  char ':' <|>
 171                  char '_' <|>
 172                  char '-' <|>
 173                  char '%' <|>
 174                  char '~' <|>
 175                  char '?' <|>
 176                  char '/' <|>
 177                  char '#' <|>
 178                  char '&' <|>
 179                  char '+'
 180
 181
 182 -- Will parse one or more url_characters
 183 url_parser :: Parser Pattern
 184 url_parser = do
 185   val <- many1 url_characters
 186   return $ Url val
 187
 188
 189 -- Will parse any of the defined patterns.
 190 value_parser :: Parser Pattern
 191 value_parser =
 192     range_parser <|>
 193     set_parser <|>
 194     url_parser <|>
 195     int_parser
 196
 197
 198 -- Uses value_parser to walk the input string,
 199 -- returning the list of parsed Patterns.
 200 main_parser :: Parser [Pattern]
 201 main_parser = do
 202   val <- many1 value_parser
 203   return val
 204
 205
 206
 207 ---------
 208 -- Main -
 209 ---------
 210
 211 collapse_ast :: [Pattern] -> [String]
 212 collapse_ast ast =
 213   nub (map concat (foldr1 cartesian_product (map to_list ast)))
 214
 215
 216 print_list :: Show a => [a] -> IO ()
 217 print_list xs = mapM_ (putStrLn . show) xs
 218
 219
 220
 221 main :: IO ()
 222 main = do
 223   argv <- getArgs
 224   (options, pattern) <- parse_command_line argv
 225
 226   -- If the user asked for help, show it and exit successfully.
 227   if (Help `elem` options)
 228       then do
 229             putStrLn help
 230             exitWith ExitSuccess
 231       else return ()
 232
 233   -- If the user didn't supply a pattern we also show the
 234   -- help, but then exit with a failure code.
 235   if (pattern == [])
 236      then do
 237            putStrLn help
 238            exitFailure
 239      else return ()
 240
 241
 242   case (parse main_parser "" (head pattern)) of
 243     Left err -> do
 244       putStrLn ("Error " ++ (show err))
 245       exitFailure
 246     Right ast -> do
 247       print_list (collapse_ast ast)
 248       exitWith ExitSuccess