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