From a60a4d3706b748116724cfc365ca925e4ecffd74 Mon Sep 17 00:00:00 2001
From: Ben Sima <ben@bsima.me>
Date: Mon, 30 Mar 2020 18:10:31 -0700
Subject: Only allow my IP to POST on /_ routes
---
Run/Que.hs | 13 +++++++++++++
1 file changed, 13 insertions(+)
(limited to 'Run')
diff --git a/Run/Que.hs b/Run/Que.hs
index aee021d..9893af2 100644
--- a/Run/Que.hs
+++ b/Run/Que.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
{- | Interprocess communication
-}
@@ -19,6 +20,7 @@ import qualified Com.Simatime.Go as Go
import qualified Control.Concurrent.STM as STM
import qualified Control.Exception as Exception
import Control.Monad.Reader ( MonadTrans )
+import qualified Data.ByteString as BS
import qualified Data.ByteString.Builder.Extra as Builder
import qualified Data.ByteString.Lazy as BSL
import Data.HashMap.Lazy ( HashMap )
@@ -29,6 +31,7 @@ import Data.Text.Lazy ( Text
)
import qualified Data.Text.Lazy as Text
import qualified Network.HTTP.Types.Status as Http
+import qualified Network.Socket as Socket
import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp
import Network.Wai.Middleware.RequestLogger
@@ -66,6 +69,14 @@ data Error = ErrorParsingOptions
instance Exception.Exception Error
+-- | Only allow my IP or local to access some route.
+guardIP :: Wai.Request -> Scotty.ActionT Text App ()
+guardIP r = case Wai.remoteHost r of
+ Socket.SockAddrInet _ ip | ip `elem` allowed -> Scotty.status Http.ok200
+ _ -> Scotty.status Http.methodNotAllowed405
+ where
+ allowed = Socket.tupleToHostAddress </ [(72, 222, 221, 62), (127, 0, 0, 1)]
+
routes :: Scotty.ScottyT Text App ()
routes = do
Scotty.middleware logStdoutDev
@@ -94,6 +105,8 @@ routes = do
-- | Put a value on a que. Returns immediately.
Scotty.post (Scotty.regex quepath) <| do
+ r <- Scotty.request
+ when (BS.isPrefixOf "/_" <| Wai.rawPathInfo r) $ guardIP r
(ns, qp) <- extract
-- ensure namespace exists
app . modify <| upsertNamespace ns
--
cgit v1.2.3