diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,10 @@ +# Changelog + +## 0.1.0.0 + +### New Features + +- Effectful effects and IO-based handlers for link-canonical URL canonicalization +- `LinkCanonical` effect for URL normalization +- `HttpHead` effect as HTTP abstraction layer +- `HttpClient` bridge instance for http-client integration diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2025 Nadeem Bitar + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/link-canonical-effectful.cabal b/link-canonical-effectful.cabal new file mode 100644 --- /dev/null +++ b/link-canonical-effectful.cabal @@ -0,0 +1,66 @@ +cabal-version: 3.0 +name: link-canonical-effectful +version: 0.1.0.0 +synopsis: Effectful integration for link-canonical +description: + Effectful effects and handlers for the link-canonical URL + canonicalization library. + +license: MIT +license-file: LICENSE +author: Nadeem Bitar +maintainer: Nadeem Bitar +category: Web, Network +build-type: Simple +extra-doc-files: CHANGELOG.md + +common common + ghc-options: + -Wall + -Wcompat + -Widentities + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wmissing-deriving-strategies + -Wpartial-fields + -Wredundant-constraints + -Wunused-packages + + default-language: GHC2024 + default-extensions: + DeriveAnyClass + DuplicateRecordFields + NoFieldSelectors + OverloadedLabels + OverloadedStrings + StrictData + TypeFamilies + UndecidableInstances + +library + import: common + hs-source-dirs: src + exposed-modules: + Effectful.Link.Canonical + Effectful.Link.Canonical.Http + + build-depends: + base >=4.18 && <5, + effectful-core >=2.5 && <2.6, + link-canonical >=0.1 && <0.2, + modern-uri >=0.3 && <0.4, + +test-suite link-canonical-effectful-test + import: common + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + base >=4.18 && <5, + containers >=0.6 && <0.8, + effectful-core >=2.5 && <2.6, + http-types >=0.12 && <0.13, + link-canonical >=0.1 && <0.2, + link-canonical-effectful, + tasty >=1.4 && <1.6, + tasty-hunit >=0.10 && <0.11, diff --git a/src/Effectful/Link/Canonical.hs b/src/Effectful/Link/Canonical.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Link/Canonical.hs @@ -0,0 +1,83 @@ +module Effectful.Link.Canonical + ( -- * Effect + LinkCanonical (..), + + -- * Operations + normalizeLink, + normalizeWithDefaults, + + -- * Handlers + runLinkCanonical, + + -- * HTTP effect + HttpHead (..), + headRequest, + runHttpHead, + + -- * Pure normalization (re-export) + Core.normalizeUri, + + -- * Configuration (re-exports) + Core.NormConfig (..), + Core.RedirectConfig (..), + Core.TrackingConfig (..), + Core.TrailingSlash (..), + Core.defaultConfig, + Core.defaultRedirectConfig, + Core.defaultTrackingConfig, + Core.defaultTrackingParams, + + -- * Result types (re-exports) + Core.NormResult (..), + Core.NormTrace (..), + + -- * Error types (re-exports) + Core.NormError (..), + Core.RedirectError (..), + Core.HttpClientError (..), + + -- * Domain rules (re-exports) + Core.DomainRule (..), + Core.defaultDomainRules, + + -- * Observability (re-exports) + Core.NormHooks (..), + + -- * URI (re-exports) + URI, + mkURI, + ) +where + +import Effectful +import Effectful.Dispatch.Dynamic +import Effectful.Link.Canonical.Http (HttpHead (..), headRequest, runHttpHead) +import Link.Canonical qualified as Core +import Text.URI (URI, mkURI) + +-- | Effect for URL canonicalization. +-- +-- Provides the same two IO-dependent operations as the core library's +-- public API: full normalization with redirect resolution, and a +-- convenience wrapper with default configuration. +data LinkCanonical :: Effect where + NormalizeLink :: Core.NormConfig -> URI -> LinkCanonical m (Either Core.NormError Core.NormResult) + NormalizeWithDefaults :: URI -> LinkCanonical m (Either Core.NormError URI) + +type instance DispatchOf LinkCanonical = Dynamic + +-- | Normalize a URL with full redirect resolution and domain-specific rules. +normalizeLink :: (LinkCanonical :> es) => Core.NormConfig -> URI -> Eff es (Either Core.NormError Core.NormResult) +normalizeLink config uri = send $ NormalizeLink config uri + +-- | Normalize a URL using default configuration, returning only the canonical URI. +normalizeWithDefaults :: (LinkCanonical :> es) => URI -> Eff es (Either Core.NormError URI) +normalizeWithDefaults = send . NormalizeWithDefaults + +-- | Run the 'LinkCanonical' effect by delegating to the core library. +-- +-- Requires 'HttpHead' in the effect stack for redirect resolution. +runLinkCanonical :: (HttpHead :> es) => Eff (LinkCanonical : es) a -> Eff es a +runLinkCanonical = interpret $ \_ -> \case + NormalizeLink config uri -> Core.normalizeLink config uri + NormalizeWithDefaults uri -> Core.normalizeWithDefaults uri diff --git a/src/Effectful/Link/Canonical/Http.hs b/src/Effectful/Link/Canonical/Http.hs new file mode 100644 --- /dev/null +++ b/src/Effectful/Link/Canonical/Http.hs @@ -0,0 +1,47 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Effectful.Link.Canonical.Http + ( -- * Effect + HttpHead (..), + + -- * Operations + headRequest, + + -- * Handlers + runHttpHead, + ) +where + +import Effectful +import Effectful.Dispatch.Dynamic +import Link.Canonical.Error (HttpClientError (..)) +import Link.Canonical.Http qualified as Core +import Text.URI (URI) + +-- | Effect for performing HTTP HEAD requests. +-- +-- This mirrors the core library's 'Core.HttpClient' typeclass as an +-- effectful effect, enabling mock handlers for testing. +data HttpHead :: Effect where + HeadRequest :: URI -> HttpHead m (Either HttpClientError Core.HttpResponse) + +type instance DispatchOf HttpHead = Dynamic + +-- | Perform an HTTP HEAD request. +headRequest :: (HttpHead :> es) => URI -> Eff es (Either HttpClientError Core.HttpResponse) +headRequest = send . HeadRequest + +-- | Run the 'HttpHead' effect using a real TLS-enabled HTTP client. +runHttpHead :: (IOE :> es) => Eff (HttpHead : es) a -> Eff es a +runHttpHead action = do + client <- Core.newHttpClientIO + interpret + ( \_ -> \case + HeadRequest uri -> liftIO $ Core.runHttpClientIO client uri + ) + action + +-- | Bridge instance: satisfy the core library's 'Core.HttpClient' constraint +-- for 'Eff es' when 'HttpHead' is in the effect stack. +instance (HttpHead :> es) => Core.HttpClient (Eff es) where + headRequest = headRequest diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,134 @@ +module Main (main) where + +import Data.Map.Strict qualified as Map +import Data.String (fromString) +import Effectful +import Effectful.Dispatch.Dynamic (interpret) +import Effectful.Link.Canonical +import GHC.Records (HasField (..)) +import Link.Canonical.Http (HttpResponse (..)) +import Network.HTTP.Types (mkStatus) +import Test.Tasty +import Test.Tasty.HUnit + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = + testGroup + "link-canonical-effectful" + [ testGroup "normalizeLink" normalizeLinkTests, + testGroup "normalizeWithDefaults" normalizeWithDefaultsTests, + testGroup "error handling" errorTests + ] + +-- | Mock HTTP handler backed by a URI -> HttpResponse map. +-- URIs not in the map return a ConnectionError. +runMockHttpHead :: Map.Map URI HttpResponse -> Eff (HttpHead : es) a -> Eff es a +runMockHttpHead responses = interpret $ \_ -> \case + HeadRequest uri -> pure $ case Map.lookup uri responses of + Just resp -> Right resp + Nothing -> Left (ConnectionError "Mock: unknown URI") + +-- | Helper to parse a URI, crashing on failure (test-only). +unsafeMkURI :: String -> URI +unsafeMkURI s = case mkURI (fromString s) of + Right u -> u + Left e -> error $ "unsafeMkURI: " <> show e + +-- | A 200 OK response with no location header. +ok200 :: HttpResponse +ok200 = + HttpResponse + { status = mkStatus 200 "OK", + location = Nothing, + headers = [] + } + +-- | A 301 redirect response pointing to the given URI. +redirect301 :: URI -> HttpResponse +redirect301 target = + HttpResponse + { status = mkStatus 301 "Moved Permanently", + location = Just target, + headers = [] + } + +normalizeLinkTests :: [TestTree] +normalizeLinkTests = + [ testCase "YouTube short URL is canonicalized" $ do + let youtubeShort = unsafeMkURI "https://youtu.be/dQw4w9WgXcQ" + youtubeCanonical = unsafeMkURI "https://www.youtube.com/watch?v=dQw4w9WgXcQ" + mockResponses = Map.singleton youtubeShort ok200 + result <- + runEff + . runMockHttpHead mockResponses + . runLinkCanonical + $ normalizeLink defaultConfig youtubeShort + case result of + Left err -> assertFailure $ "Expected Right, got Left: " <> show err + Right normResult -> getField @"canonical" normResult @?= youtubeCanonical, + testCase "tracking parameters are stripped" $ do + let input = unsafeMkURI "https://example.com/page?utm_source=share&utm_medium=social&keep=yes" + expected = unsafeMkURI "https://example.com/page?keep=yes" + mockResponses = Map.singleton input ok200 + result <- + runEff + . runMockHttpHead mockResponses + . runLinkCanonical + $ normalizeLink defaultConfig input + case result of + Left err -> assertFailure $ "Expected Right, got Left: " <> show err + Right normResult -> getField @"canonical" normResult @?= expected, + testCase "redirect chain is followed" $ do + let uriA = unsafeMkURI "https://short.link/abc" + uriB = unsafeMkURI "https://www.youtube.com/watch?v=dQw4w9WgXcQ" + youtubeCanonical = unsafeMkURI "https://www.youtube.com/watch?v=dQw4w9WgXcQ" + mockResponses = + Map.fromList + [ (uriA, redirect301 uriB), + (uriB, ok200) + ] + result <- + runEff + . runMockHttpHead mockResponses + . runLinkCanonical + $ normalizeLink defaultConfig uriA + case result of + Left err -> assertFailure $ "Expected Right, got Left: " <> show err + Right normResult -> do + getField @"canonical" normResult @?= youtubeCanonical + getField @"redirectsCount" normResult @?= 1 + ] + +normalizeWithDefaultsTests :: [TestTree] +normalizeWithDefaultsTests = + [ testCase "returns canonical URI directly" $ do + let input = unsafeMkURI "https://youtu.be/dQw4w9WgXcQ" + expected = unsafeMkURI "https://www.youtube.com/watch?v=dQw4w9WgXcQ" + mockResponses = Map.singleton input ok200 + result <- + runEff + . runMockHttpHead mockResponses + . runLinkCanonical + $ normalizeWithDefaults input + case result of + Left err -> assertFailure $ "Expected Right, got Left: " <> show err + Right uri -> uri @?= expected + ] + +errorTests :: [TestTree] +errorTests = + [ testCase "connection error is propagated" $ do + let input = unsafeMkURI "https://unknown.example.com/page" + mockResponses = Map.empty :: Map.Map URI HttpResponse + result <- + runEff + . runMockHttpHead mockResponses + . runLinkCanonical + $ normalizeLink defaultConfig input + case result of + Left _ -> pure () + Right _ -> assertFailure "Expected Left (error), got Right" + ]