never executed always true always false

    1 module PureClaw.Gateway.Routes
    2   ( -- * WAI Application
    3     mkApp
    4     -- * Request/Response types
    5   , WebhookRequest (..)
    6   , WebhookResponse (..)
    7   , ErrorResponse (..)
    8   , HealthResponse (..)
    9   ) where
   10 
   11 import Data.Aeson
   12 import Data.ByteString qualified as BS
   13 import Data.ByteString.Lazy qualified as LBS
   14 import Data.Text (Text)
   15 import Data.Text qualified as T
   16 import Data.Text.Encoding qualified as TE
   17 import Network.HTTP.Types
   18 import Network.Wai
   19 
   20 import PureClaw.Core.Errors
   21 import PureClaw.Gateway.Auth
   22 import PureClaw.Handles.Log
   23 import PureClaw.Security.Pairing
   24 
   25 -- | Health check response.
   26 newtype HealthResponse = HealthResponse
   27   { _hr_status :: Text
   28   }
   29   deriving stock (Show, Eq)
   30 
   31 instance ToJSON HealthResponse where
   32   toJSON hr = object ["status" .= _hr_status hr]
   33 
   34 -- | Error response (safe for external consumers).
   35 newtype ErrorResponse = ErrorResponse
   36   { _er_error :: Text
   37   }
   38   deriving stock (Show, Eq)
   39 
   40 instance ToJSON ErrorResponse where
   41   toJSON er = object ["error" .= _er_error er]
   42 
   43 -- | Webhook request body.
   44 data WebhookRequest = WebhookRequest
   45   { _wr_userId  :: Text
   46   , _wr_content :: Text
   47   }
   48   deriving stock (Show, Eq)
   49 
   50 instance FromJSON WebhookRequest where
   51   parseJSON = withObject "WebhookRequest" $ \o ->
   52     WebhookRequest <$> o .: "userId" <*> o .: "content"
   53 
   54 -- | Webhook response body.
   55 newtype WebhookResponse = WebhookResponse
   56   { _wrs_status :: Text
   57   }
   58   deriving stock (Show, Eq)
   59 
   60 instance ToJSON WebhookResponse where
   61   toJSON wr = object ["status" .= _wrs_status wr]
   62 
   63 -- | Build a WAI Application from the gateway dependencies.
   64 mkApp :: PairingState -> LogHandle -> Application
   65 mkApp ps lh request respond = do
   66   let method = requestMethod request
   67       path = pathInfo request
   68   case (method, path) of
   69     ("GET",  ["health"])  -> handleHealth respond
   70     ("POST", ["pair"])    -> handlePair ps lh request respond
   71     ("POST", ["webhook"]) -> handleWebhook ps lh request respond
   72     _                     -> respondError respond status404 "Not found"
   73 
   74 handleHealth :: (Response -> IO ResponseReceived) -> IO ResponseReceived
   75 handleHealth respond =
   76   respond $ jsonResponse status200 (HealthResponse "ok")
   77 
   78 handlePair :: PairingState -> LogHandle -> Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
   79 handlePair ps lh req respond = do
   80   body <- consumeRequestBody req
   81   case eitherDecode body of
   82     Left _ -> respondError respond status400 "Invalid JSON"
   83     Right pairReq -> do
   84       let clientId = clientIdFromRequest req
   85       result <- handlePairRequest ps clientId pairReq lh
   86       case result of
   87         Left err -> respondPairingError respond err
   88         Right pairResp -> respond $ jsonResponse status200 pairResp
   89 
   90 handleWebhook :: PairingState -> LogHandle -> Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived
   91 handleWebhook ps lh req respond =
   92   case lookup hAuthorization (requestHeaders req) of
   93     Nothing -> do
   94       _lh_logWarn lh "Webhook: missing Authorization header"
   95       respondError respond status401 (publicErrorText NotAllowedError)
   96     Just authHeader -> do
   97       authResult <- authenticateRequest ps authHeader lh
   98       case authResult of
   99         Left _ -> respondError respond status401 (publicErrorText NotAllowedError)
  100         Right () -> do
  101           body <- consumeRequestBody req
  102           case eitherDecode body :: Either String WebhookRequest of
  103             Left _ -> respondError respond status400 "Invalid JSON"
  104             Right _webhookReq -> do
  105               _lh_logInfo lh "Webhook: received message"
  106               respond $ jsonResponse status200 (WebhookResponse "received")
  107 
  108 -- | Consume the full request body into a lazy ByteString.
  109 consumeRequestBody :: Request -> IO LBS.ByteString
  110 consumeRequestBody req = LBS.fromChunks <$> collectChunks
  111   where
  112     collectChunks = do
  113       chunk <- getRequestBodyChunk req
  114       if BS.null chunk
  115         then pure []
  116         else (chunk :) <$> collectChunks
  117 
  118 -- | Build a JSON response with the given status code.
  119 jsonResponse :: ToJSON a => Status -> a -> Response
  120 jsonResponse st body =
  121   responseLBS st [(hContentType, "application/json")] (encode body)
  122 
  123 -- | Build an error response.
  124 respondError :: (Response -> IO ResponseReceived) -> Status -> Text -> IO ResponseReceived
  125 respondError respond st msg =
  126   respond $ jsonResponse st (ErrorResponse msg)
  127 
  128 -- | Map PairingError to HTTP response.
  129 respondPairingError :: (Response -> IO ResponseReceived) -> PairingError -> IO ResponseReceived
  130 respondPairingError respond InvalidCode = respondError respond status400 "InvalidCode"
  131 respondPairingError respond LockedOut   = respondError respond status429 "LockedOut"
  132 respondPairingError respond CodeExpired = respondError respond status400 "CodeExpired"
  133 
  134 -- | Convert PublicError to user-facing text.
  135 publicErrorText :: PublicError -> Text
  136 publicErrorText (TemporaryError msg) = msg
  137 publicErrorText RateLimitError = "Rate limit exceeded"
  138 publicErrorText NotAllowedError = "Not allowed"
  139 
  140 -- | Extract a client identifier from the request (X-Forwarded-For or remote host).
  141 clientIdFromRequest :: Request -> Text
  142 clientIdFromRequest req =
  143   case lookup "X-Forwarded-For" (requestHeaders req) of
  144     Just xff -> TE.decodeUtf8 xff
  145     Nothing  -> T.pack (show (remoteHost req))