Main.hs 3.9 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126
  1. {-# LANGUAGE OverloadedStrings #-}
  2. module Main where
  3. import Codec.Compression.GZip (decompress)
  4. import qualified Data.ByteString.Lazy.Char8 as LC
  5. import Data.IP
  6. import Data.Maybe
  7. import Network.HTTP
  8. import Network.URI
  9. import System.IO
  10. import System.Process
  11. downLoadFile :: String -> IO String --It would be better if this returned Lazy ByteString
  12. downLoadFile urlStr =
  13. do
  14. response <- simpleHTTP request
  15. case response of
  16. Left err -> error $ "Wtf Error :" ++ show err
  17. Right resp -> handleResponse resp
  18. where
  19. handleResponse resp =
  20. case rspCode resp of
  21. (2, _, _) -> return $ rspBody resp
  22. (3, _, _) -> handleRedirection resp
  23. _ -> error "what is happening"
  24. handleRedirection resp =
  25. case lookupHeader HdrLocation $ rspHeaders resp of
  26. Nothing -> error "Redirection with no location header? Wtf??"
  27. Just redirUrlStr -> downLoadFile redirUrlStr
  28. request =
  29. Request
  30. { rqURI = uriGagarin,
  31. rqMethod = GET,
  32. rqHeaders = [],
  33. rqBody = []
  34. }
  35. uriGagarin =
  36. case parseURI urlStr of
  37. Nothing -> error $ "What is this url? '" ++ urlStr ++ "' ?? This can never become a Gagarin!"
  38. Just s -> s
  39. decompressString :: String -> String
  40. decompressString = LC.unpack . decompress . LC.pack
  41. data BlockRecord
  42. = BlockRecord
  43. { description :: String,
  44. startIP :: IPv4,
  45. endIP :: IPv4
  46. }
  47. deriving (Show)
  48. breakOnLast :: (Char -> Bool) -> String -> (String, String)
  49. breakOnLast f s =
  50. let p = break f (reverse s)
  51. in (reverse . snd $ p, reverse . fst $ p)
  52. parseBlockString :: String -> [BlockRecord]
  53. parseBlockString blockStr =
  54. map toBlockRecord
  55. $ filter (\ln -> not . null $ ln)
  56. $ tail . lines
  57. $ blockStr
  58. where
  59. toBlockRecord line =
  60. case breakOnLast (\c -> c == ':') line of
  61. ([], _) -> error $ "No description in entry '" ++ line ++ "'."
  62. (descr, ipRangeStr) ->
  63. BlockRecord
  64. { description = descr,
  65. startIP = fst ips,
  66. endIP = snd ips
  67. }
  68. where
  69. ips = ipRangeToIPs ipRangeStr
  70. ipRangeToIPs :: String -> (IPv4, IPv4)
  71. ipRangeToIPs r =
  72. case break (\c -> c == '-') r of
  73. ([], _) -> error "expecting -"
  74. (ip1, ip2WithMinus) -> (strToIP ip1, strToIP $ drop 1 ip2WithMinus)
  75. where
  76. strToIP s = (read s :: IPv4)
  77. createIPsetFromBlockList :: String -> String -> IO ()
  78. createIPsetFromBlockList listName listURL =
  79. do
  80. blockListString <- downLoadFile listURL
  81. let blockList = parseBlockString $ decompressString blockListString
  82. withCreateProcess (proc "ipset" ["restore", "-!"]) {std_in = CreatePipe} $
  83. ( \h stdout stderr ph ->
  84. do
  85. hPutStrLn
  86. (fromJust h)
  87. ( "create "
  88. ++ listName
  89. ++ " hash:net family inet hashsize 262144 maxelem 524287"
  90. )
  91. mapM_
  92. ( \rec ->
  93. hPutStrLn (fromJust h) $
  94. "add "
  95. ++ listName
  96. ++ " "
  97. ++ (show $ startIP rec)
  98. ++ "-"
  99. ++ (show $ endIP rec)
  100. )
  101. blockList
  102. )
  103. data BlockList = BlockList {blockListName :: String, blockListURL :: String}
  104. blockLists :: [BlockList]
  105. blockLists =
  106. [ BlockList "iblocklist-level1" "http://list.iblocklist.com/?list=ydxerpxkpcfqjaybcssw&fileformat=p2p&archiveformat=gz",
  107. BlockList "iblocklist-level2" "http://list.iblocklist.com/?list=gyisgnzbhppbvsphucsw&fileformat=p2p&archiveformat=gz",
  108. BlockList "iblocklist-level3" "http://list.iblocklist.com/?list=uwnukjqktoggdknzrhgh&fileformat=p2p&archiveformat=gz"
  109. ]
  110. main :: IO ()
  111. main =
  112. do
  113. mapM_ (\list -> createIPsetFromBlockList (blockListName list) (blockListURL list)) blockLists
  114. putStrLn "finito la musica, pasato la fiesta"