module SavePinner.PinterestURL
( UrlKind (..)
, PinterestUrl (..)
, ParseError (..)
, parsePinterestUrl
, normalizePinterestUrl
, isPinterestUrl
, isPinterestHost
) where
import Data.Char (isAlphaNum, isDigit, isSpace, toLower)
import Data.List (dropWhileEnd)
import Network.URI (URI (..), URIAuth (..), parseURI)
data UrlKind = Pin | Short | Profile | Board | Ideas
deriving (Eq, Show)
data PinterestUrl = PinterestUrl
{ urlKind :: UrlKind
, originalUrl :: String
, normalizedUrl :: String
, normalizedHost :: String
, pinId :: Maybe String
, shortCode :: Maybe String
, username :: Maybe String
, boardSlug :: Maybe String
, ideaSlug :: Maybe String
, ideaId :: Maybe String
}
deriving (Eq, Show)
data ParseError
= InvalidUrl String
| UnsupportedUrl String
deriving (Eq, Show)
parsePinterestUrl :: String -> Either ParseError PinterestUrl
parsePinterestUrl input = do
let original = trim input
if null original || length original > 2048
then Left (InvalidUrl "URL is empty or too long")
else pure ()
uri <- maybe (Left (InvalidUrl "URL could not be parsed")) Right (parseURI original)
authority <- maybe (Left (InvalidUrl "URL has no host")) Right (uriAuthority uri)
let scheme = lower (uriScheme uri)
host = lower (uriRegName authority)
port = uriPort authority
if scheme /= "https:"
then Left (InvalidUrl "Only HTTPS URLs are supported")
else pure ()
if not (null (uriUserInfo authority)) || port `notElem` ["", ":443"]
then Left (InvalidUrl "Credentials and non-standard ports are not supported")
else pure ()
route original host (pathSegments (uriPath uri))
normalizePinterestUrl :: String -> Either ParseError String
normalizePinterestUrl value = normalizedUrl <$> parsePinterestUrl value
isPinterestUrl :: String -> Bool
isPinterestUrl = either (const False) (const True) . parsePinterestUrl
isPinterestHost :: String -> Bool
isPinterestHost host = lower host `elem` pinterestHosts
route :: String -> String -> [String] -> Either ParseError PinterestUrl
route original "pin.it" [code]
| validShortCode code = Right
((emptyResult Short original ("https://pin.it/" ++ code ++ "/") "pin.it")
{ shortCode = Just code })
route _ "pin.it" _ = Left (UnsupportedUrl "Unsupported pin.it path")
route original host segments
| not (isPinterestHost host) = Left (InvalidUrl "Host is not an allowed Pinterest domain")
| otherwise = routePinterest original segments
routePinterest :: String -> [String] -> Either ParseError PinterestUrl
routePinterest original [first, value]
| lower first == "pin"
, Just ident <- extractPinId value = Right (pinResult original ident)
routePinterest original [first, value, trailing]
| lower first == "pin"
, Just ident <- extractPinId value
, validBoardSlug trailing = Right (pinResult original ident)
routePinterest original [first, slug, ident]
| lower first == "ideas"
, validBoardSlug slug
, validNumericId ident = Right
((emptyResult Ideas original normalized canonicalHost)
{ ideaSlug = Just slug
, ideaId = Just ident
})
where
normalized = "https://" ++ canonicalHost ++ "/ideas/" ++ slug ++ "/" ++ ident ++ "/"
routePinterest original [name]
| validUsername name
, lower name `notElem` reservedFirstSegments = Right
((emptyResult Profile original normalized canonicalHost)
{ username = Just name })
where
normalized = "https://" ++ canonicalHost ++ "/" ++ name ++ "/"
routePinterest original [name, slug]
| validUsername name
, lower name `notElem` reservedFirstSegments
, validBoardSlug slug = Right
((emptyResult Board original normalized canonicalHost)
{ username = Just name
, boardSlug = Just slug
})
where
normalized = "https://" ++ canonicalHost ++ "/" ++ name ++ "/" ++ slug ++ "/"
routePinterest _ _ = Left (UnsupportedUrl "Unsupported Pinterest path")
pinResult :: String -> String -> PinterestUrl
pinResult original ident = (emptyResult Pin original normalized canonicalHost)
{ pinId = Just ident }
where
normalized = "https://" ++ canonicalHost ++ "/pin/" ++ ident ++ "/"
emptyResult :: UrlKind -> String -> String -> String -> PinterestUrl
emptyResult kind original normalized host = PinterestUrl
{ urlKind = kind
, originalUrl = original
, normalizedUrl = normalized
, normalizedHost = host
, pinId = Nothing
, shortCode = Nothing
, username = Nothing
, boardSlug = Nothing
, ideaSlug = Nothing
, ideaId = Nothing
}
extractPinId :: String -> Maybe String
extractPinId value
| validNumericId value = Just value
| otherwise =
let (reversedDigits, rest) = span isDigit (reverse value)
slug = reverse (drop 2 rest)
ident = reverse reversedDigits
in if take 2 rest == "--" && validBoardSlug slug && validNumericId ident
then Just ident
else Nothing
validNumericId :: String -> Bool
validNumericId value = not (null value) && length value <= 20 && all isDigit value
validShortCode :: String -> Bool
validShortCode value = length value >= 2 && all isAlphaNum value
validUsername :: String -> Bool
validUsername [] = False
validUsername (first : rest) =
(isAlphaNum first || first == '_') && all isUsernameChar rest
where
isUsernameChar char = isAlphaNum char || char `elem` "_.-"
validBoardSlug :: String -> Bool
validBoardSlug [] = False
validBoardSlug (first : rest) = isAlphaNum first && all isSlugChar rest
where
isSlugChar char = isAlphaNum char || char `elem` "_-"
pathSegments :: String -> [String]
pathSegments path = filter (not . null) (splitOnSlash path)
splitOnSlash :: String -> [String]
splitOnSlash [] = []
splitOnSlash value =
let withoutSlash = dropWhile (== '/') value
(segment, remainder) = break (== '/') withoutSlash
in if null withoutSlash then [] else segment : splitOnSlash remainder
trim :: String -> String
trim = dropWhileEnd isSpace . dropWhile isSpace
lower :: String -> String
lower = map toLower
canonicalHost :: String
canonicalHost = "www.pinterest.com"
reservedFirstSegments :: [String]
reservedFirstSegments =
[ "business", "categories", "explore", "help", "ideas", "login"
, "logout", "oauth", "pin", "pin-builder", "resource", "search"
, "settings", "signup", "today", "topics"
]
pinterestHosts :: [String]
pinterestHosts =
[ "pinterest.com", "www.pinterest.com", "m.pinterest.com"
, "pinterest.at", "www.pinterest.at", "pinterest.be", "www.pinterest.be"
, "pinterest.ca", "www.pinterest.ca", "pinterest.ch", "www.pinterest.ch"
, "pinterest.cl", "www.pinterest.cl", "pinterest.co", "www.pinterest.co"
, "pinterest.co.kr", "www.pinterest.co.kr", "pinterest.co.nz", "www.pinterest.co.nz"
, "pinterest.co.uk", "www.pinterest.co.uk", "pinterest.com.au", "www.pinterest.com.au"
, "pinterest.com.br", "www.pinterest.com.br", "pinterest.com.mx", "www.pinterest.com.mx"
, "pinterest.com.pe", "www.pinterest.com.pe", "pinterest.com.tr", "www.pinterest.com.tr"
, "pinterest.cz", "www.pinterest.cz", "pinterest.de", "www.pinterest.de"
, "pinterest.dk", "www.pinterest.dk", "pinterest.es", "www.pinterest.es"
, "pinterest.fi", "www.pinterest.fi", "pinterest.fr", "www.pinterest.fr"
, "pinterest.gr", "www.pinterest.gr", "pinterest.hu", "www.pinterest.hu"
, "pinterest.id", "www.pinterest.id", "pinterest.ie", "www.pinterest.ie"
, "pinterest.it", "www.pinterest.it", "pinterest.jp", "www.pinterest.jp"
, "pinterest.nl", "www.pinterest.nl", "pinterest.no", "www.pinterest.no"
, "pinterest.ph", "www.pinterest.ph", "pinterest.pl", "www.pinterest.pl"
, "pinterest.pt", "www.pinterest.pt", "pinterest.ro", "www.pinterest.ro"
, "pinterest.se", "www.pinterest.se", "pinterest.sk", "www.pinterest.sk"
, "at.pinterest.com", "au.pinterest.com", "be.pinterest.com", "br.pinterest.com"
, "ca.pinterest.com", "ch.pinterest.com", "cl.pinterest.com", "co.pinterest.com"
, "cz.pinterest.com", "de.pinterest.com", "dk.pinterest.com", "es.pinterest.com"
, "fi.pinterest.com", "fr.pinterest.com", "gr.pinterest.com", "hu.pinterest.com"
, "id.pinterest.com", "ie.pinterest.com", "it.pinterest.com", "jp.pinterest.com"
, "kr.pinterest.com", "mx.pinterest.com", "nl.pinterest.com", "no.pinterest.com"
, "nz.pinterest.com", "pe.pinterest.com", "ph.pinterest.com", "pl.pinterest.com"
, "pt.pinterest.com", "ro.pinterest.com", "se.pinterest.com", "sk.pinterest.com"
, "tr.pinterest.com", "uk.pinterest.com"
]