Initial commit.

diff --git a/hfusk.hs b/hfusk.hs
new file mode 100644 (file)
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] <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

diff --git a/makefile b/makefile
new file mode 100644 (file)
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