Only allow my IP to POST on /_ routes

1 files changed, 13 insertions, 0 deletions

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