link-canonical-effectful (empty) → 0.1.0.0

raw patch · 6 files changed

+361/−0 lines, 6 filesdep +basedep +containersdep +effectful-core

Dependencies added: base, containers, effectful-core, http-types, link-canonical, link-canonical-effectful, modern-uri, tasty, tasty-hunit

Files

CHANGELOG.md +10/−0
LICENSE +21/−0
link-canonical-effectful.cabal +66/−0
src/Effectful/Link/Canonical.hs +83/−0
src/Effectful/Link/Canonical/Http.hs +47/−0
test/Main.hs +134/−0

+ CHANGELOG.md view

@@ -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

+ LICENSE view

@@ -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.

+ link-canonical-effectful.cabal view

@@ -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,

+ src/Effectful/Link/Canonical.hs view

@@ -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

+ src/Effectful/Link/Canonical/Http.hs view

@@ -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

+ test/Main.hs view

@@ -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"+  ]