never executed always true always false

    1 module PureClaw.Handles.Network
    2   ( -- * URL authorization (constructor intentionally NOT exported)
    3     AllowedUrl
    4   , UrlError (..)
    5   , mkAllowedUrl
    6   , getAllowedUrl
    7     -- * Response type
    8   , HttpResponse (..)
    9     -- * Handle type
   10   , NetworkHandle (..)
   11     -- * Implementations
   12   , mkNetworkHandle
   13   , mkNoOpNetworkHandle
   14   ) where
   15 
   16 import Data.ByteString (ByteString)
   17 import Data.ByteString.Lazy qualified as BL
   18 import Data.Text (Text)
   19 import Data.Text qualified as T
   20 import Network.HTTP.Client qualified as HTTP
   21 import Network.HTTP.Types.Header qualified as Header
   22 import Network.HTTP.Types.Status qualified as Status
   23 
   24 import PureClaw.Core.Types
   25 
   26 -- | A URL that has been validated against a domain allow-list.
   27 -- Constructor is intentionally NOT exported — the only way to obtain an
   28 -- 'AllowedUrl' is through 'mkAllowedUrl'.
   29 --
   30 -- Follows the same proof-carrying pattern as 'SafePath' and
   31 -- 'AuthorizedCommand': the type is evidence that validation occurred.
   32 newtype AllowedUrl = AllowedUrl { getAllowedUrl :: Text }
   33   deriving stock (Eq, Ord)
   34 
   35 instance Show AllowedUrl where
   36   show u = "AllowedUrl " ++ show (getAllowedUrl u)
   37 
   38 -- | Errors from URL validation.
   39 data UrlError
   40   = UrlNotAllowed Text   -- ^ URL's domain is not in the allow-list
   41   | UrlMalformed Text    -- ^ URL could not be parsed
   42   deriving stock (Show, Eq)
   43 
   44 -- | Validate a URL against an allow-list of permitted domains.
   45 -- The URL must start with @https://@ and its domain must be in the list.
   46 mkAllowedUrl :: AllowList Text -> Text -> Either UrlError AllowedUrl
   47 mkAllowedUrl allowList url
   48   | not (T.isPrefixOf "https://" url) && not (T.isPrefixOf "http://" url) =
   49       Left (UrlMalformed url)
   50   | isAllowed allowList domain = Right (AllowedUrl url)
   51   | otherwise = Left (UrlNotAllowed url)
   52   where
   53     domain = extractDomain url
   54 
   55 -- | Extract the domain from a URL. Simple extraction — takes the text
   56 -- between @://@ and the next @/@ (or end of string).
   57 extractDomain :: Text -> Text
   58 extractDomain url =
   59   let afterScheme = T.drop 1 $ T.dropWhile (/= '/') $ T.drop 1 $ T.dropWhile (/= '/') url
   60       -- afterScheme is everything after "://"
   61       -- For "https://example.com/path", we want "example.com"
   62   in T.takeWhile (\c -> c /= '/' && c /= ':' && c /= '?') afterScheme
   63 
   64 -- | HTTP response from a network request.
   65 data HttpResponse = HttpResponse
   66   { _hr_statusCode :: Int
   67   , _hr_body       :: ByteString
   68   }
   69   deriving stock (Show, Eq)
   70 
   71 -- | HTTP network capability. Only accepts 'AllowedUrl', which is proof
   72 -- that the URL passed domain validation.
   73 data NetworkHandle = NetworkHandle
   74   { _nh_httpGet  :: AllowedUrl -> IO HttpResponse
   75   , _nh_httpPost :: AllowedUrl -> ByteString -> IO HttpResponse
   76   , _nh_httpGetWithHeaders :: AllowedUrl -> [Header.Header] -> IO HttpResponse
   77   }
   78 
   79 -- | Real network handle using @http-client@.
   80 mkNetworkHandle :: HTTP.Manager -> NetworkHandle
   81 mkNetworkHandle manager = NetworkHandle
   82   { _nh_httpGet = \url -> do
   83       req <- HTTP.parseRequest (T.unpack (getAllowedUrl url))
   84       resp <- HTTP.httpLbs req manager
   85       pure HttpResponse
   86         { _hr_statusCode = Status.statusCode (HTTP.responseStatus resp)
   87         , _hr_body       = BL.toStrict (HTTP.responseBody resp)
   88         }
   89   , _nh_httpPost = \url body -> do
   90       initReq <- HTTP.parseRequest (T.unpack (getAllowedUrl url))
   91       let req = initReq
   92             { HTTP.method = "POST"
   93             , HTTP.requestBody = HTTP.RequestBodyBS body
   94             }
   95       resp <- HTTP.httpLbs req manager
   96       pure HttpResponse
   97         { _hr_statusCode = Status.statusCode (HTTP.responseStatus resp)
   98         , _hr_body       = BL.toStrict (HTTP.responseBody resp)
   99         }
  100   , _nh_httpGetWithHeaders = \url headers -> do
  101       req <- HTTP.parseRequest (T.unpack (getAllowedUrl url))
  102       let req' = req { HTTP.requestHeaders = headers }
  103       resp <- HTTP.httpLbs req' manager
  104       pure HttpResponse
  105         { _hr_statusCode = Status.statusCode (HTTP.responseStatus resp)
  106         , _hr_body       = BL.toStrict (HTTP.responseBody resp)
  107         }
  108   }
  109 
  110 -- | No-op network handle. Returns 200 with empty body.
  111 mkNoOpNetworkHandle :: NetworkHandle
  112 mkNoOpNetworkHandle = NetworkHandle
  113   { _nh_httpGet  = \_ -> pure HttpResponse { _hr_statusCode = 200, _hr_body = "" }
  114   , _nh_httpPost = \_ _ -> pure HttpResponse { _hr_statusCode = 200, _hr_body = "" }
  115   , _nh_httpGetWithHeaders = \_ _ -> pure HttpResponse { _hr_statusCode = 200, _hr_body = "" }
  116   }