Skip to content

Instantly share code, notes, and snippets.

@thumphries

thumphries/client.hs

Last active May 11, 2018 04:17
Download ZIP

Revisions

  1. thumphries revised this gist Aug 9, 2017. 1 changed file with 13 additions and 2 deletions.
    15 changes: 13 additions & 2 deletions client.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -3,6 +3,7 @@

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

    import Data.ByteString (ByteString)
    import qualified Data.ByteString.Lazy as BSL
    @@ -16,6 +17,7 @@ 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
    @@ -76,14 +78,14 @@ sitePost storage request =
    -- 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 of
    case muri >>= safeUri of
    Just uri -> do
    mtxt <- getText uri
    case mtxt of
    @@ -150,3 +152,12 @@ getText uri = do
    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
  2. thumphries revised this gist Aug 9, 2017. 1 changed file with 1 addition and 4 deletions.
    5 changes: 1 addition & 4 deletions client.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -14,7 +14,6 @@ import Data.Text (Text)
    import qualified Data.Text as T
    import qualified Data.Text.Encoding as TE

    import Debug.Trace
    import qualified Network.HTTP.Types as HTTP
    import Network.URI (URI, parseAbsoluteURI, uriToString)
    import qualified Network.Wai as Wai
    @@ -77,8 +76,7 @@ sitePost storage request =
    -- Don't do this in production or you'll be DDoSed! Use requestSizeCheck first
    body <- Wai.strictRequestBody request
    sitePostForm storage (BSL.toStrict body)
    _ -> do
    traceM "foo"
    _ ->
    pure status400

    sitePostForm :: Storage -> ByteString -> IO Wai.Response
    @@ -90,7 +88,6 @@ sitePostForm storage body = do
    mtxt <- getText uri
    case mtxt of
    Just txt -> do
    traceM (show uri)
    i <- insert storage txt
    pure (plain HTTP.status201 [(HTTP.hLocation, location i)] "Created")
    Nothing ->
  3. thumphries created this gist Aug 9, 2017.
    155 changes: 155 additions & 0 deletions client.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,155 @@
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE PatternSynonyms #-}

    import Control.Applicative
    import Control.Lens

    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 Debug.Trace
    import qualified Network.HTTP.Types as HTTP
    import Network.URI (URI, parseAbsoluteURI, uriToString)
    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
    traceM "foo"
    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 of
    Just uri -> do
    mtxt <- getText uri
    case mtxt of
    Just txt -> do
    traceM (show uri)
    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"]
    42 changes: 42 additions & 0 deletions redirect.cabal
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,42 @@
    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.*
    26 changes: 26 additions & 0 deletions server.hs
    View file
    Original file line number Diff line number Diff line change
    @@ -0,0 +1,26 @@
    {-# 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"