diff options
| -rw-r--r-- | .tasks/tasks.jsonl | 2 | ||||
| -rwxr-xr-x | Biz/Que/Host.hs | 73 |
2 files changed, 61 insertions, 14 deletions
diff --git a/.tasks/tasks.jsonl b/.tasks/tasks.jsonl index 5440bb8..bb5a64f 100644 --- a/.tasks/tasks.jsonl +++ b/.tasks/tasks.jsonl @@ -156,5 +156,5 @@ {"taskCreatedAt":"2025-11-21T04:30:05.792313193Z","taskDependencies":[],"taskId":"t-rWacMb1av","taskNamespace":"Omni/Task.hs","taskParent":null,"taskPriority":"P2","taskStatus":"Review","taskTitle":"Make task IDs case-insensitive","taskType":"WorkTask","taskUpdatedAt":"2025-11-21T08:18:06.371310379Z"} {"taskCreatedAt":"2025-11-13T19:38:07.804316976Z","taskDependencies":[],"taskId":"t-1f9QP23","taskNamespace":null,"taskParent":null,"taskPriority":"P2","taskStatus":"Open","taskTitle":"General Code Quality Refactor","taskType":"Epic","taskUpdatedAt":"2025-11-13T19:38:07.804316976Z"} {"taskCreatedAt":"2025-11-20T21:41:20.029426381Z","taskDependencies":[],"taskId":"t-1ne7Qtj","taskNamespace":"Network/Wai/Middleware/Braid.hs","taskParent":"t-1f9QP23","taskPriority":"P2","taskStatus":"Review","taskTitle":"Implement Braid keep-alive mechanism","taskType":"WorkTask","taskUpdatedAt":"2025-11-21T08:23:00.872672096Z"} -{"taskCreatedAt":"2025-11-20T21:41:20.048368004Z","taskDependencies":[],"taskId":"t-1ne7VoO","taskNamespace":"Biz/Que/Host.hs","taskParent":"t-1f9QP23","taskPriority":"P2","taskStatus":"InProgress","taskTitle":"Revive authkey authentication in Que/Host","taskType":"WorkTask","taskUpdatedAt":"2025-11-21T08:23:10.857520064Z"} +{"taskCreatedAt":"2025-11-20T21:41:20.048368004Z","taskDependencies":[],"taskId":"t-1ne7VoO","taskNamespace":"Biz/Que/Host.hs","taskParent":"t-1f9QP23","taskPriority":"P2","taskStatus":"Done","taskTitle":"Revive authkey authentication in Que/Host","taskType":"WorkTask","taskUpdatedAt":"2025-11-21T08:35:15.03814935Z"} {"taskCreatedAt":"2025-11-20T21:41:20.067644599Z","taskDependencies":[],"taskId":"t-1ne80pJ","taskNamespace":"Biz/Dragons.hs","taskParent":"t-1f9QP23","taskPriority":"P2","taskStatus":"Done","taskTitle":"Store generated JWK in persistent file","taskType":"WorkTask","taskUpdatedAt":"2025-11-20T22:54:17.655700806Z"} diff --git a/Biz/Que/Host.hs b/Biz/Que/Host.hs index 834ce0e..34b1a01 100755 --- a/Biz/Que/Host.hs +++ b/Biz/Que/Host.hs @@ -34,6 +34,7 @@ import Data.HashMap.Lazy (HashMap) import qualified Data.HashMap.Lazy as HashMap import Network.HTTP.Media ((//), (/:)) import qualified Network.Wai.Handler.Warp as Warp +import Network.Socket (SockAddr (..)) import qualified Omni.Cli as Cli import qualified Omni.Log as Log import Omni.Test ((@=?)) @@ -75,7 +76,30 @@ Usage: |] test :: Test.Tree -test = Test.group "Biz.Que.Host" [Test.unit "id" <| 1 @=? (1 :: Integer)] +test = + Test.group + "Biz.Que.Host" + [ Test.unit "id" <| 1 @=? (1 :: Integer), + Test.unit "putQue requires auth for '_'" <| do + st <- atomically <| STM.newTVar mempty + let cfg = Envy.defConfig + let handlers = paths cfg + + -- Case 1: No auth, should fail + let nonLocalHost = SockAddrInet 0 0 + let handler1 = putQue handlers nonLocalHost Nothing "_" "testq" "body" + res1 <- Servant.runHandler (runReaderT handler1 st) + case res1 of + Left err -> if errHTTPCode err == 401 then pure () else Test.assertFailure ("Expected 401, got " <> show err) + Right _ -> Test.assertFailure "Expected failure, got success" + + -- Case 2: Correct auth, should succeed + let handler2 = putQue handlers nonLocalHost (Just "admin-key") "_" "testq" "body" + res2 <- Servant.runHandler (runReaderT handler2 st) + case res2 of + Left err -> Test.assertFailure (show err) + Right _ -> pure () + ] type App = ReaderT AppState Servant.Handler @@ -125,23 +149,31 @@ data Paths path = Paths :- Get '[JSON] NoContent, dash :: path - :- "_" + :- RemoteHost + :> Header "Authorization" Text + :> "_" :> "dash" :> Get '[JSON] Ques, getQue :: path - :- Capture "ns" Text + :- RemoteHost + :> Header "Authorization" Text + :> Capture "ns" Text :> Capture "quename" Text :> Get '[PlainText, HTML, OctetStream] Message, getStream :: path - :- Capture "ns" Text + :- RemoteHost + :> Header "Authorization" Text + :> Capture "ns" Text :> Capture "quename" Text :> "stream" :> StreamGet NoFraming OctetStream (SourceIO Message), putQue :: path - :- Capture "ns" Text + :- RemoteHost + :> Header "Authorization" Text + :> Capture "ns" Text :> Capture "quepath" Text :> ReqBody '[PlainText, HTML, OctetStream] Text :> Post '[PlainText, HTML, OctetStream] NoContent @@ -149,15 +181,15 @@ data Paths path = Paths deriving (Generic) paths :: Config -> Paths (AsServerT App) -paths _ = - -- TODO revive authkey stuff - -- - read Authorization header, compare with queSkey - -- - Only allow my IP or localhost to publish to '_' namespace +paths Config {..} = Paths { home = throwError <| err301 {errHeaders = [("Location", "/_/index")]}, - dash = gets, - getQue = \ns qn -> do + dash = \rh mAuth -> do + checkAuth queSkey rh mAuth "_" + gets, + getQue = \rh mAuth ns qn -> do + checkAuth queSkey rh mAuth ns guardNs ns ["pub", "_"] modify <| upsertNamespace ns q <- que ns qn @@ -165,7 +197,8 @@ paths _ = |> liftIO +> Go.tap |> liftIO, - getStream = \ns qn -> do + getStream = \rh mAuth ns qn -> do + checkAuth queSkey rh mAuth ns guardNs ns ["pub", "_"] modify <| upsertNamespace ns q <- que ns qn @@ -174,7 +207,8 @@ paths _ = +> Go.tap |> Source.fromAction (const False) -- peek chan instead of False? |> pure, - putQue = \ns qp body -> do + putQue = \rh mAuth ns qp body -> do + checkAuth queSkey rh mAuth ns guardNs ns ["pub", "_"] modify <| upsertNamespace ns q <- que ns qp @@ -188,6 +222,19 @@ paths _ = >> pure NoContent } +checkAuth :: Text -> SockAddr -> Maybe Text -> Text -> App () +checkAuth skey rh mAuth ns = do + let authorized = mAuth == Just skey + let isLocal = isLocalhost rh + when (ns == "_" && not (authorized || isLocal)) <| do + throwError err401 {errBody = "Authorized access only for '_' namespace"} + +isLocalhost :: SockAddr -> Bool +isLocalhost (SockAddrInet _ h) = h == 0x0100007f -- 127.0.0.1 +isLocalhost (SockAddrInet6 _ _ (0, 0, 0, 1) _) = True -- ::1 +isLocalhost (SockAddrUnix _) = True +isLocalhost _ = False + -- | Given `guardNs ns whitelist`, if `ns` is not in the `whitelist` -- list, return a 405 error. guardNs :: (Applicative a, MonadError ServerError a) => Text -> [Text] -> a () |