RemoteId.hs

{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}

module Portage.Metadata.RemoteId
    (
      -- * Remote id
      RemoteId (..)
      -- * Pretty printing
    , prettyPrintRemoteIds
    , prettyPrintRemoteId
      -- * Parsing
    , URIParser (..)
    , matchURIs
    , matchURI
    , runUriParser
    , definedParsers
      -- ** Individual parsers
    , hackageParser
    , bitbucketParser
    , codebergParser
    , freedesktopParser
    , gentooParser
    , githubParser
    , gitlabParser
    , gnomeParser
    , kdeParser
    , launchpadParser
    , osdnParser
    , savannahParser
    , savannahNonGnuParser
    , sourceforgeParser
    , sourcehutParser
      -- ** Utility
      -- *** URI scheme
    , httpScheme
      -- *** URI domain
    , Domain
    , domainOrWWW
    , subdomain
      -- *** URI path
    , Path
    , stripPrefix
    , stripPrefixP
    , gitPath
      -- *** Misc
    , ignore
    , allChars
    ) where

import Control.Monad
import Data.Foldable (asum)
import qualified Data.List as L
import Data.Maybe (mapMaybe)
import qualified Data.Set as S
import Network.URI (URI(..), URIAuth(..), parseURI)
import System.FilePath.Posix
import Text.Parsec
import Text.Parsec.String

-- | Many of these are unlikely to source any Haskell code, but they are added
-- for completeness. The full list can be seen at:
-- <https://github.com/pkgcore/pkgcheck/blob/master/src/pkgcheck/checks/network.py>
data RemoteId
    = RemoteIdHackage String       -- ^ Hackage package
    | RemoteIdBitbucket String String -- ^ Bitbucket project
    | RemoteIdCodeberg String String -- ^ Codeberg project
    | RemoteIdFreedesktop String String -- ^ Freedesktop GitLab project
    | RemoteIdGentoo String        -- ^ Gentoo project
    | RemoteIdGithub String String -- ^ Github user and repo
    | RemoteIdGitlab String String -- ^ Gitlab user and repo
    | RemoteIdGnome String String  -- ^ Gnome GitLab project
    | RemoteIdKDE String String    -- ^ KDE Invent project
    | RemoteIdLaunchpad String     -- ^ Launchpad project
    | RemoteIdOSDN String          -- ^ OSDN project
    | RemoteIdSavannah String      -- ^ GNU Savannah project
    | RemoteIdSavannahNonGNU String -- ^ NonGNU Savannah project
    | RemoteIdSourceforge String   -- ^ Sourceforge project
    | RemoteIdSourcehut String String -- ^ sourcehut project
    deriving (Show, Eq, Ord)

-- | A set of parsers to use on a 'URI'. Each parser can produce an arbitrary
--   type. These intermediate types are coalesced in 'mkRemoteId' and
--   are hidden from the top-level using the @ExistentialQuantification@
--   language extension.
data URIParser = forall scheme user regname port path query fragment. URIParser
    { schemeParser :: Parser scheme     -- | ^ scheme
    , userParser :: Parser user         -- | ^ user
    , regnameParser :: Parser regname   -- | ^ domain
    , portParser :: Parser port         -- | ^ port
    , pathParser :: Parser path         -- | ^ path
    , queryParser :: Parser query       -- | ^ query
    , fragmentParser :: Parser fragment -- | ^ fragment
      -- | coalescing function
    , mkRemoteId :: scheme -> user -> regname -> port -> path -> query -> fragment -> RemoteId
    }

type Domain = String
type Path = String

-- | Pretty print a 'S.Set' of 'RemoteId's as XML. Wraps the block in @"<upstream>"@.
prettyPrintRemoteIds :: S.Set RemoteId -> [String]
prettyPrintRemoteIds set
    | S.null set = []
    | otherwise =
        ["\t<upstream>"]
        ++ (prettyPrintRemoteId <$> S.toAscList set)
        ++ ["\t</upstream>"]

-- | Pretty print a single 'RemoteId'.
prettyPrintRemoteId :: RemoteId -> String
prettyPrintRemoteId = \case
    RemoteIdHackage p     -> pp "hackage"     p
    RemoteIdBitbucket u r -> pp "bitbucket"   $ u ++ "/" ++ r
    RemoteIdCodeberg u r  -> pp "codeberg"    $ u ++ "/" ++ r
    RemoteIdFreedesktop u r -> pp "freedesktop-gitlab" $ u ++ "/" ++ r
    RemoteIdGentoo p      -> pp "gentoo"      p
    RemoteIdGithub u r    -> pp "github"      $ u ++ "/" ++ r
    RemoteIdGitlab u r    -> pp "gitlab"      $ u ++ "/" ++ r
    RemoteIdGnome u r     -> pp "gnome-gitlab" $ u ++ "/" ++ r
    RemoteIdLaunchpad p   -> pp "launchpad"   p
    RemoteIdKDE u r       -> pp "kde-invent"  $ u ++ "/" ++ r
    RemoteIdOSDN p        -> pp "osdn"        p
    RemoteIdSavannah p    -> pp "savannah"    p
    RemoteIdSavannahNonGNU p -> pp "savannah-nongnu" p
    RemoteIdSourceforge p -> pp "sourceforge" p
    RemoteIdSourcehut u r -> pp "sourcehut"   $ u ++ "/" ++ r
  where
    pp t v = "\t\t<remote-id type=\"" ++ t ++ "\">" ++ v ++ "</remote-id>"

-- | Run 'matchURI' on all given strings, collecting the result in a 'S.Set'.
matchURIs :: [String] -> S.Set RemoteId
matchURIs = S.fromList . mapMaybe matchURI

-- | Try to parse the given string using any of the defined URI parsers
matchURI :: String -> Maybe RemoteId
matchURI str = asum $ map runUriP definedParsers
  where
    runUriP :: URIParser -> Maybe RemoteId
    runUriP p = eitherToMaybe $ runUriParser p str

    -- @Maybe@ is an Alternative, whereas @Either e@ is not. This is needed
    -- to make 'asum' work.
    eitherToMaybe :: Either e a -> Maybe a
    eitherToMaybe (Left  _) = Nothing
    eitherToMaybe (Right x) = Just x

-- | All parsers defined in this module
definedParsers :: [URIParser]
definedParsers =
    [ hackageParser
    , bitbucketParser
    , codebergParser
    , freedesktopParser
    , gentooParser
    , githubParser
    , gitlabParser
    , gnomeParser
    , kdeParser
    , launchpadParser
    , osdnParser
    , savannahParser
    , savannahNonGnuParser
    , sourceforgeParser
    , sourcehutParser
    ]

-- | @'hackage': 'https://hackage.haskell.org/package/{project}'@
hackageParser :: URIParser
hackageParser = URIParser
    httpScheme
    ignore
    (string "hackage.haskell.org")
    ignore
    (do
        (p:_) <- stripPrefixP "/package"
        pure p
    )
    ignore
    ignore
    (\_ _ _ _ p _ _ -> RemoteIdHackage p)

-- | @"bitbucket": "https://bitbucket.org/{project}"@
bitbucketParser :: URIParser
bitbucketParser = URIParser
    (choice [httpScheme, string "git:"])
    ignore
    (domainOrWWW "bitbucket.org")
    ignore
    (do
        (u:r:_) <- stripPrefixP "/"
        (u,) <$> gitPath r
    )
    ignore
    ignore
    (\_ _ _ _ (u,r) _ _ -> RemoteIdBitbucket u r)

-- | @"codeberg": "https://codeberg.org/{project}"@
codebergParser :: URIParser
codebergParser = URIParser
    (choice [httpScheme, string "git:"])
    ignore
    (domainOrWWW "codeberg.org")
    ignore
    (do
        (u:r:_) <- stripPrefixP "/"
        (u,) <$> gitPath r
    )
    ignore
    ignore
    (\_ _ _ _ (u,r) _ _ -> RemoteIdCodeberg u r)

-- | @"freedesktop-gitlab": "https://gitlab.freedesktop.org/{project}.git/"@
freedesktopParser :: URIParser
freedesktopParser = URIParser
    (choice [httpScheme, string "git:"])
    ignore
    (domainOrWWW "gitlab.freedesktop.org")
    ignore
    (do
        (u:r:_) <- stripPrefixP "/"
        (u,) <$> gitPath r
    )
    ignore
    ignore
    (\_ _ _ _ (u,r) _ _ -> RemoteIdFreedesktop u r)

-- | @'gentoo': 'https://gitweb.gentoo.org/{project}.git/'@
gentooParser :: URIParser
gentooParser = URIParser
    httpScheme
    ignore
    (string "gitweb.gentoo.org")
    ignore
    (do
        (s:_) <- stripPrefixP "/"
        gitPath s
    )
    ignore
    ignore
    (\_ _ _ _ p _ _ -> RemoteIdGentoo p)

-- | @'github': 'https://github.com/{project}'@
githubParser :: URIParser
githubParser = URIParser
    (choice [httpScheme, string "git:"])
    ignore
    (domainOrWWW "github.com")
    ignore
    (do
        (u:r:_) <- stripPrefixP "/"
        (u,) <$> gitPath r
    )
    ignore
    ignore
    (\_ _ _ _ (u,r) _ _ -> RemoteIdGithub u r)

-- | @'gitlab': 'https://gitlab.com/{project}'@
gitlabParser :: URIParser
gitlabParser = URIParser
    (choice [httpScheme, string "git:"])
    ignore
    (domainOrWWW "gitlab.com")
    ignore
    (do
        (u:r:_) <- stripPrefixP "/"
        (u,) <$> gitPath r
    )
    ignore
    ignore
    (\_ _ _ _ (u,r) _ _ -> RemoteIdGitlab u r)

-- | @"gnome-gitlab": "https://gitlab.gnome.org/{project}.git/"@
gnomeParser :: URIParser
gnomeParser = URIParser
    (choice [httpScheme, string "git:"])
    ignore
    (domainOrWWW "gitlab.gnome.org")
    ignore
    (do
        (u:r:_) <- stripPrefixP "/"
        (u,) <$> gitPath r
    )
    ignore
    ignore
    (\_ _ _ _ (u,r) _ _ -> RemoteIdGnome u r)

-- | @"kde-invent": "https://invent.kde.org/{project}"@
kdeParser :: URIParser
kdeParser = URIParser
    (choice [httpScheme, string "git:"])
    ignore
    (domainOrWWW "invent.kde.org")
    ignore
    (do
        (u:r:_) <- stripPrefixP "/"
        (u,) <$> gitPath r
    )
    ignore
    ignore
    (\_ _ _ _ (u,r) _ _ -> RemoteIdKDE u r)

-- | @'launchpad': 'https://launchpad.net/{project}'@
launchpadParser :: URIParser
launchpadParser = URIParser
    httpScheme
    ignore
    (domainOrWWW "launchpad.net")
    ignore
    (do
        (p:_) <- stripPrefixP "/"
        pure p
    )
    ignore
    ignore
    (\_ _ _ _ p _ _ -> RemoteIdLaunchpad p)

-- | @'osdn': 'https://osdn.net/projects/{project}/'@
osdnParser :: URIParser
osdnParser = URIParser
    httpScheme
    ignore
    (domainOrWWW "osdn.net")
    ignore
    (do
        (p:_) <- stripPrefixP "/projects"
        pure p
    )
    ignore
    ignore
    (\_ _ _ _ p _ _ -> RemoteIdOSDN p)

-- | @"savannah": "https://savannah.gnu.org/projects/{project}"@
savannahParser :: URIParser
savannahParser = URIParser
    httpScheme
    ignore
    (string "savannah.gnu.org")
    ignore
    (do
        (p:_) <- stripPrefixP "/projects"
        pure p
    )
    ignore
    ignore
    (\_ _ _ _ p _ _ -> RemoteIdSavannah p)

-- | @"savannah-nongnu": "https://savannah.nongnu.org/projects/{project}"@
savannahNonGnuParser :: URIParser
savannahNonGnuParser = URIParser
    httpScheme
    ignore
    (string "savannah.nongnu.org")
    ignore
    (do
        (p:_) <- stripPrefixP "/projects"
        pure p
    )
    ignore
    ignore
    (\_ _ _ _ p _ _ -> RemoteIdSavannahNonGNU p)

-- | @'sourceforge': 'https://sourceforge.net/projects/{project}/'@
sourceforgeParser :: URIParser
sourceforgeParser = URIParser
    httpScheme
    ignore
    (domainOrWWW "sourceforge.net")
    ignore
    (do
        (p:_) <- stripPrefixP "/projects"
        pure p
    )
    ignore
    ignore
    (\_ _ _ _ p _ _ -> RemoteIdSourceforge p)

-- | @"sourcehut": "https://sr.ht/{project}/"@
sourcehutParser :: URIParser
sourcehutParser = URIParser
    (choice [httpScheme, string "git:"])
    ignore
    (subdomain "sr.ht")
    ignore
    (do
        (u:r:_) <- stripPrefixP "/"
        (u,) <$> gitPath r
    )
    ignore
    ignore
    (\_ _ _ _ (u,r) _ _ -> RemoteIdSourcehut u r)

-- | Run a specified 'URIParser' with a string
--
--   Internally, uses 'parseURI' to create a 'URI', and then uses each
--   parser specified in 'URIParser' on a specific part of the uri. These
--   intermediate results are coalesced with the supplied 'mkRemoteId'.
runUriParser
  :: URIParser
  -> String
  -> Either ParseError RemoteId
runUriParser (URIParser {..}) = join . parseIt go
  where
    go :: Parser (Either ParseError RemoteId)
    go = do
        cs <- allChars
        case parseURI cs of
            Just (URI scheme (Just (URIAuth user regname port)) path query fragment) ->
                pure $ mkRemoteId
                    <$> parseIt schemeParser scheme
                    <*> parseIt userParser user
                    <*> parseIt regnameParser regname
                    <*> parseIt portParser port
                    <*> parseIt pathParser path
                    <*> parseIt queryParser query
                    <*> parseIt fragmentParser fragment
            _ -> fail $ "Could not parse as a URI: " ++ show cs

    parseIt :: Parser a -> String -> Either ParseError a
    parseIt p = parse p ""

-- | Convenience function for 'stripPrefix', which uses 'allChars' as the
--   target path. Throws a parse error if 'stripPrefix' fails.
stripPrefixP
    :: Path -- ^ The prefix path to strip
    -> Parser [String]
stripPrefixP pre = do
    targ <- allChars
    case stripPrefix pre targ of
        Just ps -> pure ps
        Nothing -> fail $ "Path prefix does not match: \n"
            ++ "pre = " ++ show pre ++ "\n"
            ++ "targ = " ++ show targ ++ "\n"
            ++ "L.stripPrefix " ++ show (splitDirectories pre)
                ++ " " ++ show (splitDirectories targ) ++ " = Nothing"

-- | Strips a path of a prefix, then returns the result split along path
--   seperators. Returns 'Nothing' if the prefix path does not match the
--   beginning of the target path.
--
--   Examples:
--
--   >>> stripPrefix "/web/packages" "/web/packages/foo/"
--   Just ["foo"]
--
--   >>> stripPrefix "/" "/foo/bar"
--   Just ["foo","bar"]
--
--   >>> stripPrefix "" "/foo/bar"
--   Just ["/","foo","bar"]
--
--   >>> stripPrefix "/some/thing" "/something/else"
--   Nothing
stripPrefix
    :: Path -- ^ The prefix path to strip
    -> Path -- ^ The target path to strip from
    -> Maybe [String]
stripPrefix pre targ =
    L.stripPrefix
        (splitDirectories pre)
        (splitDirectories targ)

-- | Compares the input stream to the given domain. Parser succeeds if
--   either of the following is true:
--
--   * The input stream matches the target domain exactly
--   * The input stream matches the target domain prepended by @"www."@
--
--   e.g.
--
--   > domainOrWWW "github.com"
--
--   will match on @"github.com"@ or @"www.github.com"@
domainOrWWW
    :: Domain
    -> Parser ()
domainOrWWW targ = do
    sub <- allChars
    if sub == ("www." ++ targ) || sub == targ
        then pure ()
        else fail $ "domainOrWWW did not match:"
            ++ "\nsub: " ++ show sub
            ++ "\ntarg: " ++ show targ

-- | Remove any ".git" suffix from the specified string
gitPath
    :: String
    -> Parser String
gitPath p = case parse go "" p of
    Left e  -> fail $ show e -- Not ideal, but it works
    Right r -> pure r
  where
    go :: Parser String
    go = choice
        [ try $ manyTill anyChar (string ".git") <* eof
        , allChars
        ]

-- | Compares the input stream to the given domain. Parser succeeds if the
--   input stream is a subdomain of the target.
subdomain
    :: Domain -- ^ Target domain to match against
    -> Parser ()
subdomain targ = do
    sub <- allChars
    if targ `L.isSuffixOf` sub
        then pure ()
        else fail $ show sub ++ " is not a subdomain of " ++ show targ

ignore :: Parser ()
ignore = pure ()

-- | Matches either of the strings @"http:"@ or @"https:"@
httpScheme :: Parser String
httpScheme = choice
    [ try $ string "https:"
    , string "http:"
    ]

-- | Match on every character from the input stream
allChars :: Parser String
allChars = many anyChar