Finally fixed the guardIP thing

Turns out the ultimate reason was that I wasn't actually returning out
of the handler, I was just setting the HTTP status. Now I'm sure that it
works correctly.

1 files changed, 10 insertions, 12 deletions

diff --git a/Run/Que/Server.hs b/Run/Que/Server.hs
index e0327a5..218c821 100644
--- a/Run/Que/Server.hs
+++ b/Run/Que/Server.hs
@@ -29,7 +29,6 @@ import           Data.Text.Lazy                 ( Text
                                                 , fromStrict
                                                 )
 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
@@ -67,14 +66,6 @@ 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 </ [(73, 222, 221, 62), (127, 0, 0, 1)]
-
 routes :: Scotty.ScottyT Text App ()
 routes = do
   Scotty.middleware logStdout
@@ -111,10 +102,17 @@ routes = do
   --
   -- Put a value on a que. Returns immediately.
   Scotty.post (Scotty.regex quepath) <| do
-    r        <- Scotty.request
+    xFwdHost <- Scotty.header "X-Forwarded-Host"
+    xRealIP  <- Scotty.header "X-Real-IP"
+    host     <- Scotty.header "Host"
     (ns, qp) <- extract
-    -- "_" is a special, internal namespace that only I can use
-    when ("_" == ns) <| guardIP r
+    -- Only allow my IP or localhost to access '_' namespace
+    when ("_" == ns) <| case (xFwdHost, xRealIP, host) of
+      (Just "73.222.221.62", _, _) -> Scotty.status Http.ok200
+      (_, Just "73.222.221.62", _) -> Scotty.status Http.ok200
+      (Just "::1", Just "::1", Just "localhost") -> Scotty.status Http.ok200
+      _ -> Scotty.status Http.methodNotAllowed405
+        >> Scotty.text "error 405 not allowed: _ is a reserved namespace"
     app . modify <| upsertNamespace ns
     q     <- app <| que ns qp
     qdata <- Scotty.body