purl (empty) → 0.1.0.0
raw patch · 5 files changed
+542/−0 lines, 5 filesdep +aesondep +basedep +case-insensitive
Dependencies added: aeson, base, case-insensitive, containers, http-types, parsec, purl, tasty, tasty-hunit, text
Files
- CHANGELOG.md +3/−0
- README.md +7/−0
- purl.cabal +48/−0
- src/Data/Purl.hs +320/−0
- test/Spec.hs +164/−0
+ CHANGELOG.md view
@@ -0,0 +1,3 @@+# 0.1.0.0++Introduction
+ README.md view
@@ -0,0 +1,7 @@+# purl++This project aims to support [purl (universal package URL)](https://github.com/package-url/purl-spec).++## Building++We aim to support both regular cabal-based and nix-based builds.
+ purl.cabal view
@@ -0,0 +1,48 @@+cabal-version: 3.0+name: purl+version: 0.1.0.0+synopsis: Support for purl (mostly universal package url).+description:+ Support for the purl specification: <https://github.com/package-url/purl-spec>++license: BSD-3-Clause+author: Gautier DI FOLCO+maintainer: foss@difolco.dev+category: Data+extra-doc-files: CHANGELOG.md, README.md+tested-with:+ GHC ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.8 || ==9.6.6 || ==9.8.3 || ==9.10.1 || ==9.12.1++library+ exposed-modules: Data.Purl+ build-depends:+ , base >=4.14 && <5+ , aeson >=2.0 && <2.3+ , case-insensitive <1.3+ , containers >=0.6 && <0.8+ , http-types >=0.10.0 && <0.13+ , parsec ==3.1.*+ , text >=1.2 && <3++ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options:+ -Wall -Wcompat -Widentities -Wincomplete-record-updates+ -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints++test-suite spec+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends:+ , base <5+ , containers+ , purl+ , tasty <2+ , tasty-hunit <1.0+ , text++ default-language: Haskell2010+ ghc-options:+ -Wall -Wcompat -Widentities -Wincomplete-record-updates+ -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints
+ src/Data/Purl.hs view
@@ -0,0 +1,320 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralisedNewtypeDeriving #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StrictData #-}++-- | This module provides support for the purl specification: <https://github.com/package-url/purl-spec>+module Data.Purl (+ -- * Types+ Purl (..),+ PurlScheme (..),+ PurlType (..),+ PurlNamespace (..),+ PurlName (..),+ PurlVersion (..),+ PurlQualifierKey (..),+ PurlQualifierValue (..),+ PurlSubPath (..),++ -- * Helpers+ newPurl,+ newPurlHackage,+ newPurlGhc,+ newPurlOther,+ addPurlQuantifier,+ addPurlQuantifiers,+ findPurlQuantifiers,++ -- * Parsers+ parsePurl,+ purlP,+ purlSchemeP,+ purlTypeP,+ purlNamespaceP,+ purlNameP,+ purlVersionP,+ purlQualifiersP,+ purlSubPathP,++ -- * Renderers+ purlText,++ -- * instances+ FromJSON (..),+ ToJSON (..),+)+where++import Control.Monad (guard)+import Data.Aeson+import Data.CaseInsensitive (CI, mk, original)+import Data.Char+import Data.List (nub)+import Data.Map.Strict qualified as M+import Data.Maybe (mapMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as TE+import GHC.Generics+import Network.HTTP.Types (urlDecode)+import Text.Parsec++-- * Types++{- | Purl representation+scheme:type/namespace/name@version?qualifiers#subpath+-}+data Purl = Purl+ { purlScheme :: PurlScheme+ , purlType :: PurlType+ , purlNamespace :: Maybe PurlNamespace+ , purlName :: PurlName+ , purlVersion :: Maybe PurlVersion+ , purlQualifiers :: M.Map PurlQualifierKey PurlQualifierValue+ , purlSubPath :: Maybe PurlSubPath+ }+ deriving stock (Eq, Show, Generic)++-- | scheme: this is the URL scheme with the constant value of "pkg".+data PurlScheme+ = Pkg+ deriving stock (Eq, Show, Generic)++-- | type: the package "type" or package "protocol" such as maven, npm, nuget, gem, pypi, etc.+data PurlType+ = Hackage+ | Ghc+ | OtherType (CI Text)+ deriving stock (Eq, Show, Generic)++-- | namespace: some name prefix such as a Maven groupid, a Docker image owner, a GitHub user or organization.+newtype PurlNamespace = PurlNamespace {unPurlNamespace :: [Text]}+ deriving newtype (Eq)++instance Show PurlNamespace where+ showsPrec n = showsPrec n . T.intercalate "/" . unPurlNamespace++-- | name: the name of the package.+newtype PurlName = PurlName {unPurlName :: Text}+ deriving newtype (Eq, Show)++-- | version: the version of the package.+newtype PurlVersion = PurlVersion {unPurlVersion :: Text}+ deriving newtype (Eq, Show)++-- | qualifier: extra qualifying data for a package such as an OS, architecture, a distro, etc.+newtype PurlQualifierKey = PurlQualifierKey {unPurlQualifierKey :: Text}+ deriving newtype (Eq, Ord, Show)++-- | qualifier: extra qualifying data for a package such as an OS, architecture, a distro, etc.+newtype PurlQualifierValue = PurlQualifierValue {unPurlQualifierValue :: Text}+ deriving newtype (Eq, Ord, Show)++-- | subpath: extra subpath within a package, relative to the package root.+newtype PurlSubPath = PurlSubPath {unPurlSubPath :: [Text]}+ deriving newtype (Eq)++instance Show PurlSubPath where+ showsPrec n = showsPrec n . T.intercalate "/" . unPurlSubPath++-- * Helpers++-- | Create a minimal 'Purl'+newPurl :: PurlType -> PurlName -> Purl+newPurl pType pName =+ Purl+ { purlScheme = Pkg+ , purlType = pType+ , purlNamespace = Nothing+ , purlName = pName+ , purlVersion = Nothing+ , purlQualifiers = mempty+ , purlSubPath = Nothing+ }++-- | Create a minimal 'Purl' of type 'Hackage'+newPurlHackage :: PurlName -> Purl+newPurlHackage = newPurl Hackage++-- | Create a minimal 'Purl' of type 'GHC'+newPurlGhc :: PurlName -> Purl+newPurlGhc = newPurl Ghc++-- | Create a minimal 'Purl' of type 'Other'+newPurlOther :: Text -> PurlName -> Purl+newPurlOther other = newPurl (OtherType $ mk other)++-- | Prepend a qualifiers+addPurlQuantifier :: PurlQualifierKey -> PurlQualifierValue -> Purl -> Purl+addPurlQuantifier k v = addPurlQuantifiers [(k, v)]++-- | Prepend a list of qualifiers+addPurlQuantifiers :: [(PurlQualifierKey, PurlQualifierValue)] -> Purl -> Purl+addPurlQuantifiers xs p = p{purlQualifiers = M.fromList xs <> purlQualifiers p}++-- | Find all the 'PurlQualifierValue' associated to a 'PurlQualifierKey'+findPurlQuantifiers :: PurlQualifierKey -> Purl -> Maybe PurlQualifierValue+findPurlQuantifiers k = M.lookup k . purlQualifiers++-- * Parsers++parsePurl :: Text -> Either ParseError Purl+parsePurl = runParser purlP () "parsePurl"++{- | Parses the whole 'Purl'+scheme:type/namespace/name@version?qualifiers#subpath+-}+purlP :: Parsec Text u Purl+purlP =+ Purl+ <$> purlSchemeP+ <*> purlTypeP+ <*> optionMaybe purlNamespaceP+ <*> purlNameP+ <*> optionMaybe purlVersionP+ <*> purlQualifiersP+ <*> purlSubPathP++-- | Parses the constant scheme "pkg:"+purlSchemeP :: Parsec Text u PurlScheme+purlSchemeP = Pkg <$ (string "pkg:" *> many (char '/'))++-- | Parses the package type+purlTypeP :: Parsec Text u PurlType+purlTypeP = toType <$> purlTypeStr <* char '/'+ where+ purlTypeStr = do+ first <- satisfy isAsciiLetter+ rest <- takeWhileP isTypeChar+ return $ T.toLower (first `T.cons` rest)++ isAsciiLetter c = isAscii c && isLetter c+ isTypeChar c = isAscii c && (isAlphaNum c || c `elem` (".+-" :: String))++ toType =+ \case+ "hackage" -> Hackage+ "ghc" -> Ghc+ other -> OtherType $ mk other++-- | Parses the optional namespace, stripping leading/trailing slashes and decoding segments+purlNamespaceP :: Parsec Text u PurlNamespace+purlNamespaceP = do+ raw <- many $ try $ takeWhile1P (`notElem` ("/@?#" :: String)) <* char '/'+ let decoded = mapMaybe decodeSegment raw+ guard $ not $ null decoded+ return . PurlNamespace $ decoded+ where+ decodeSegment seg+ | T.null seg = Nothing+ | '/' `elem` T.unpack (unescapeURL seg) = Nothing+ | otherwise = Just seg++-- | Parses the package name (percent-decoded)+purlNameP :: Parsec Text u PurlName+purlNameP = PurlName <$> takeWhile1P notTerminator+ where+ notTerminator c = c /= '@' && c /= '?' && c /= '#'++-- | Parses the optional version (percent-decoded), prefixed by '@'+purlVersionP :: Parsec Text u PurlVersion+purlVersionP = char '@' *> (PurlVersion <$> takeWhile1P notTerminator)+ where+ notTerminator c = c /= '?' && c /= '#'++-- | Parses the optional list of qualifiers prefixed by '?'+purlQualifiersP :: Parsec Text u (M.Map PurlQualifierKey PurlQualifierValue)+purlQualifiersP = option mempty $ char '?' *> qualifiers+ where+ qualifiers = do+ qualifierPairs <- sepBy1 qualifier (char '&')+ let keys = map fst qualifierPairs+ guard (length keys == length (nub keys))+ return $ M.fromList qualifierPairs++ qualifier = do+ key <- takeWhile1P isKeyChar+ guard (not (T.null key) && isAsciiLetter (T.head key))+ _ <- char '='+ val <- takeWhile1P (/= '&')+ guard (not (T.null val))+ return (PurlQualifierKey key, PurlQualifierValue val)++ isAsciiLetter c = isAscii c && isLetter c+ isKeyChar c = isAscii c && (isAlphaNum c || c `elem` (".-_" :: String))++-- | Parses the optional subpath (percent-decoded and normalized), prefixed by '#'+purlSubPathP :: Parsec Text u (Maybe PurlSubPath)+purlSubPathP = optionMaybe $ char '#' *> (PurlSubPath <$> segments)+ where+ segments = do+ rawSegs <- takeWhileP (/= '/') `sepBy` char '/'+ let decoded = mapMaybe decodeSegment rawSegs+ guard (not (null decoded))+ return decoded++ decodeSegment seg =+ let s = unescapeURL seg+ in if T.null s || s == "." || s == ".." || "/" `T.isInfixOf` s+ then Nothing+ else Just s++-- * Parsing helpers++takeWhileP :: (Char -> Bool) -> Parsec Text u Text+takeWhileP f = T.pack <$> many (satisfy f)++takeWhile1P :: (Char -> Bool) -> Parsec Text u Text+takeWhile1P f = T.pack <$> many1 (satisfy f)++unescapeURL :: Text -> Text+unescapeURL = TE.decodeUtf8 . urlDecode True . TE.encodeUtf8++-- * Renderers+purlText :: Purl -> Text+purlText purl =+ T.concat+ [ renderedPackage+ , renderedType+ , renderedNamespace+ , renderedName+ , renderedVersion+ , renderedQuelifiers+ , renderedSubPath+ ]+ where+ renderedPackage = "pkg:"+ renderedType =+ case purlType purl of+ Hackage -> "hackage"+ Ghc -> "ghc"+ OtherType x -> T.toCaseFold $ original x+ renderedNamespace =+ maybe "" (("/" <>) . T.intercalate "/" . unPurlNamespace) $ purlNamespace purl+ renderedName =+ "/" <> unPurlName (purlName purl)+ renderedVersion = maybe "" (("@" <>) . unPurlVersion) $ purlVersion purl+ renderedQuelifiers =+ if M.null (purlQualifiers purl)+ then ""+ else+ "?"+ <> T.intercalate+ "&"+ ( map (\(PurlQualifierKey k, PurlQualifierValue v) -> k <> "=" <> v) $+ M.toList (purlQualifiers purl)+ )+ renderedSubPath = maybe "" (("#" <>) . T.intercalate "/" . unPurlSubPath) $ purlSubPath purl++-- * instances++instance ToJSON Purl where+ toJSON = toJSON . purlText+ toEncoding = toEncoding . purlText++instance FromJSON Purl where+ parseJSON =+ withText "Purl" $ either (fail . show) return . parsePurl
+ test/Spec.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import Control.Monad+import Data.Bifunctor (Bifunctor (bimap))+import Data.Map.Strict qualified as M+import Data.Purl+import Data.Text (Text)+import Test.Tasty+import Test.Tasty.HUnit++main :: IO ()+main = defaultMain $+ testCase "Data.Purl" $ do+ forM_ examples $ \(purlString, expectedPurl) -> do+ case parsePurl purlString of+ Left e -> assertFailure (show e)+ Right purl -> do+ purl @?= expectedPurl+ purlText purl @?= purlString++examples :: [(Text, Purl)]+examples =+ [+ ( "pkg:bitbucket/birkenfeld/pygments-main@244fd47e07d1014f0aed9c"+ , (newPurlOther "bitbucket" (PurlName "pygments-main"))+ { purlNamespace = Just $ PurlNamespace ["birkenfeld"]+ , purlVersion = Just $ PurlVersion "244fd47e07d1014f0aed9c"+ }+ )+ ,+ ( "pkg:deb/debian/curl@7.50.3-1?arch=i386&distro=jessie"+ , (newPurlOther "deb" (PurlName "curl"))+ { purlNamespace = Just $ PurlNamespace ["debian"]+ , purlVersion = Just $ PurlVersion "7.50.3-1"+ , purlQualifiers = mkQualifiers [("arch", "i386"), ("distro", "jessie")]+ }+ )+ ,+ ( "pkg:docker/cassandra@sha256:244fd47e07d1004f0aed9c"+ , (newPurlOther "docker" (PurlName "cassandra"))+ { purlVersion = Just $ PurlVersion "sha256:244fd47e07d1004f0aed9c"+ }+ )+ ,+ ( "pkg:docker/customer/dockerimage@sha256:244fd47e07d1004f0aed9c?repository_url=gcr.io"+ , (newPurlOther "docker" (PurlName "dockerimage"))+ { purlNamespace = Just $ PurlNamespace ["customer"]+ , purlVersion = Just $ PurlVersion "sha256:244fd47e07d1004f0aed9c"+ , purlQualifiers = mkQualifiers [("repository_url", "gcr.io")]+ }+ )+ ,+ ( "pkg:gem/jruby-launcher@1.1.2?platform=java"+ , (newPurlOther "gem" (PurlName "jruby-launcher"))+ { purlVersion = Just $ PurlVersion "1.1.2"+ , purlQualifiers = mkQualifiers [("platform", "java")]+ }+ )+ ,+ ( "pkg:gem/ruby-advisory-db-check@0.12.4"+ , (newPurlOther "gem" (PurlName "ruby-advisory-db-check"))+ { purlVersion = Just $ PurlVersion "0.12.4"+ }+ )+ ,+ ( "pkg:github/package-url/purl-spec@244fd47e07d1004f0aed9c"+ , (newPurlOther "github" (PurlName "purl-spec"))+ { purlNamespace = Just $ PurlNamespace ["package-url"]+ , purlVersion = Just $ PurlVersion "244fd47e07d1004f0aed9c"+ }+ )+ ,+ ( "pkg:golang/google.golang.org/genproto#googleapis/api/annotations"+ , (newPurlOther "golang" (PurlName "genproto"))+ { purlNamespace = Just $ PurlNamespace ["google.golang.org"]+ , purlSubPath = Just $ PurlSubPath ["googleapis", "api", "annotations"]+ }+ )+ ,+ ( "pkg:maven/org.apache.xmlgraphics/batik-anim@1.9.1?packaging=sources"+ , (newPurlOther "maven" (PurlName "batik-anim"))+ { purlNamespace = Just $ PurlNamespace ["org.apache.xmlgraphics"]+ , purlVersion = Just $ PurlVersion "1.9.1"+ , purlQualifiers = mkQualifiers [("packaging", "sources")]+ }+ )+ ,+ ( "pkg:maven/org.apache.xmlgraphics/batik-anim@1.9.1?repository_url=repo.spring.io/release"+ , (newPurlOther "maven" (PurlName "batik-anim"))+ { purlNamespace = Just $ PurlNamespace ["org.apache.xmlgraphics"]+ , purlVersion = Just $ PurlVersion "1.9.1"+ , purlQualifiers = mkQualifiers [("repository_url", "repo.spring.io/release")]+ }+ )+ ,+ ( "pkg:golang/google.golang.org/genproto#googleapis/api/annotations"+ , (newPurlOther "golang" (PurlName "genproto"))+ { purlNamespace = Just $ PurlNamespace ["google.golang.org"]+ , purlSubPath = Just $ PurlSubPath ["googleapis", "api", "annotations"]+ }+ )+ ,+ ( "pkg:maven/org.apache.xmlgraphics/batik-anim@1.9.1?packaging=sources"+ , (newPurlOther "maven" (PurlName "batik-anim"))+ { purlNamespace = Just $ PurlNamespace ["org.apache.xmlgraphics"]+ , purlVersion = Just $ PurlVersion "1.9.1"+ , purlQualifiers = mkQualifiers [("packaging", "sources")]+ }+ )+ ,+ ( "pkg:maven/org.apache.xmlgraphics/batik-anim@1.9.1?repository_url=repo.spring.io/release"+ , (newPurlOther "maven" (PurlName "batik-anim"))+ { purlNamespace = Just $ PurlNamespace ["org.apache.xmlgraphics"]+ , purlVersion = Just $ PurlVersion "1.9.1"+ , purlQualifiers = mkQualifiers [("repository_url", "repo.spring.io/release")]+ }+ )+ ,+ ( "pkg:npm/%40angular/animation@12.3.1"+ , (newPurlOther "npm" (PurlName "animation"))+ { purlNamespace = Just $ PurlNamespace ["%40angular"]+ , purlVersion = Just $ PurlVersion "12.3.1"+ }+ )+ ,+ ( "pkg:npm/foobar@12.3.1"+ , (newPurlOther "npm" (PurlName "foobar"))+ { purlVersion = Just $ PurlVersion "12.3.1"+ }+ )+ ,+ ( "pkg:nuget/EnterpriseLibrary.Common@6.0.1304"+ , (newPurlOther "nuget" (PurlName "EnterpriseLibrary.Common"))+ { purlVersion = Just $ PurlVersion "6.0.1304"+ }+ )+ ,+ ( "pkg:pypi/django@1.11.1"+ , (newPurlOther "pypi" (PurlName "django"))+ { purlVersion = Just $ PurlVersion "1.11.1"+ }+ )+ ,+ ( "pkg:rpm/fedora/curl@7.50.3-1.fc25?arch=i386&distro=fedora-25"+ , (newPurlOther "rpm" (PurlName "curl"))+ { purlNamespace = Just $ PurlNamespace ["fedora"]+ , purlVersion = Just $ PurlVersion "7.50.3-1.fc25"+ , purlQualifiers = mkQualifiers [("arch", "i386"), ("distro", "fedora-25")]+ }+ )+ ,+ ( "pkg:rpm/opensuse/curl@7.56.1-1.1.?arch=i386&distro=opensuse-tumbleweed"+ , (newPurlOther "rpm" (PurlName "curl"))+ { purlNamespace = Just $ PurlNamespace ["opensuse"]+ , purlVersion = Just $ PurlVersion "7.56.1-1.1."+ , purlQualifiers = mkQualifiers [("arch", "i386"), ("distro", "opensuse-tumbleweed")]+ }+ )+ ]+ where+ mkQualifiers = M.fromList . map (bimap PurlQualifierKey PurlQualifierValue)