module Hpack.Syntax.Defaults (
Defaults(..)
, Github(..)
, Local(..)
#ifdef TEST
, isValidOwner
, isValidRepo
#endif
) where
import Data.HashMap.Lazy (member)
import Data.List
import qualified Data.Text as T
import System.FilePath.Posix (splitDirectories)
import Data.Aeson.Config.FromValue
import Hpack.Syntax.Git
data ParseGithub = ParseGithub {
parseGithubGithub :: GithubRepo
, parseGithubRef :: Ref
, parseGithubPath :: Maybe Path
} deriving (Generic, FromValue)
data GithubRepo = GithubRepo {
githubRepoOwner :: String
, githubRepoName :: String
}
instance FromValue GithubRepo where
fromValue = withString parseGithub
parseGithub :: String -> Parser GithubRepo
parseGithub github
| not (isValidOwner owner) = fail ("invalid owner name " ++ show owner)
| not (isValidRepo repo) = fail ("invalid repository name " ++ show repo)
| otherwise = return (GithubRepo owner repo)
where
(owner, repo) = drop 1 <$> break (== '/') github
isValidOwner :: String -> Bool
isValidOwner owner =
not (null owner)
&& all isAlphaNumOrHyphen owner
&& doesNotHaveConsecutiveHyphens owner
&& doesNotBeginWithHyphen owner
&& doesNotEndWithHyphen owner
where
isAlphaNumOrHyphen = (`elem` '-' : alphaNum)
doesNotHaveConsecutiveHyphens = not . isInfixOf "--"
doesNotBeginWithHyphen = not . isPrefixOf "-"
doesNotEndWithHyphen = not . isSuffixOf "-"
isValidRepo :: String -> Bool
isValidRepo repo =
not (null repo)
&& repo `notElem` [".", ".."]
&& all isValid repo
where
isValid = (`elem` '_' : '.' : '-' : alphaNum)
alphaNum :: [Char]
alphaNum = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9']
data Ref = Ref {unRef :: String}
instance FromValue Ref where
fromValue = withString parseRef
parseRef :: String -> Parser Ref
parseRef ref
| isValidRef ref = return (Ref ref)
| otherwise = fail ("invalid Git reference " ++ show ref)
data Path = Path {unPath :: [FilePath]}
instance FromValue Path where
fromValue = withString parsePath
parsePath :: String -> Parser Path
parsePath path
| '\\' `elem` path = fail ("rejecting '\\' in " ++ show path ++ ", please use '/' to separate path components")
| ':' `elem` path = fail ("rejecting ':' in " ++ show path)
| "/" `elem` p = fail ("rejecting absolute path " ++ show path)
| ".." `elem` p = fail ("rejecting \"..\" in " ++ show path)
| otherwise = return (Path p)
where
p = splitDirectories path
data Github = Github {
githubOwner :: String
, githubRepo :: String
, githubRef :: String
, githubPath :: [FilePath]
} deriving (Eq, Show)
toDefaultsGithub :: ParseGithub -> Github
toDefaultsGithub ParseGithub{..} = Github {
githubOwner = githubRepoOwner parseGithubGithub
, githubRepo = githubRepoName parseGithubGithub
, githubRef = unRef parseGithubRef
, githubPath = maybe [".hpack", "defaults.yaml"] unPath parseGithubPath
}
parseDefaultsGithubFromString :: String -> Parser ParseGithub
parseDefaultsGithubFromString xs = case break (== '@') xs of
(github, '@' : ref) -> ParseGithub <$> parseGithub github <*> parseRef ref <*> pure Nothing
_ -> fail ("missing Git reference for " ++ show xs ++ ", the expected format is owner/repo@ref")
data Local = Local {
localLocal :: String
} deriving (Eq, Show, Generic, FromValue)
data Defaults = DefaultsLocal Local | DefaultsGithub Github
deriving (Eq, Show)
instance FromValue Defaults where
fromValue v = case v of
String s -> DefaultsGithub . toDefaultsGithub <$> parseDefaultsGithubFromString (T.unpack s)
Object o | "local" `member` o -> DefaultsLocal <$> fromValue v
Object o | "github" `member` o -> DefaultsGithub . toDefaultsGithub <$> fromValue v
Object _ -> fail "neither key \"github\" nor key \"local\" present"
_ -> typeMismatch "Object or String" v