{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} 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 { ParseGithub -> GithubRepo parseGithubGithub :: GithubRepo , ParseGithub -> Ref parseGithubRef :: Ref , ParseGithub -> Maybe Path parseGithubPath :: Maybe Path } deriving ((forall x. ParseGithub -> Rep ParseGithub x) -> (forall x. Rep ParseGithub x -> ParseGithub) -> Generic ParseGithub forall x. Rep ParseGithub x -> ParseGithub forall x. ParseGithub -> Rep ParseGithub x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a $cto :: forall x. Rep ParseGithub x -> ParseGithub $cfrom :: forall x. ParseGithub -> Rep ParseGithub x Generic, Value -> Parser ParseGithub (Value -> Parser ParseGithub) -> FromValue ParseGithub forall a. (Value -> Parser a) -> FromValue a fromValue :: Value -> Parser ParseGithub $cfromValue :: Value -> Parser ParseGithub FromValue) data GithubRepo = GithubRepo { GithubRepo -> String githubRepoOwner :: String , GithubRepo -> String githubRepoName :: String } instance FromValue GithubRepo where fromValue :: Value -> Parser GithubRepo fromValue = (String -> Parser GithubRepo) -> Value -> Parser GithubRepo forall a. (String -> Parser a) -> Value -> Parser a withString String -> Parser GithubRepo parseGithub parseGithub :: String -> Parser GithubRepo parseGithub :: String -> Parser GithubRepo parseGithub String github | Bool -> Bool not (String -> Bool isValidOwner String owner) = String -> Parser GithubRepo forall (m :: * -> *) a. MonadFail m => String -> m a fail (String "invalid owner name " String -> String -> String forall a. [a] -> [a] -> [a] ++ String -> String forall a. Show a => a -> String show String owner) | Bool -> Bool not (String -> Bool isValidRepo String repo) = String -> Parser GithubRepo forall (m :: * -> *) a. MonadFail m => String -> m a fail (String "invalid repository name " String -> String -> String forall a. [a] -> [a] -> [a] ++ String -> String forall a. Show a => a -> String show String repo) | Bool otherwise = GithubRepo -> Parser GithubRepo forall (m :: * -> *) a. Monad m => a -> m a return (String -> String -> GithubRepo GithubRepo String owner String repo) where (String owner, String repo) = Int -> String -> String forall a. Int -> [a] -> [a] drop Int 1 (String -> String) -> (String, String) -> (String, String) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (Char -> Bool) -> String -> (String, String) forall a. (a -> Bool) -> [a] -> ([a], [a]) break (Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == Char '/') String github isValidOwner :: String -> Bool isValidOwner :: String -> Bool isValidOwner String owner = Bool -> Bool not (String -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null String owner) Bool -> Bool -> Bool && (Char -> Bool) -> String -> Bool forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool all Char -> Bool isAlphaNumOrHyphen String owner Bool -> Bool -> Bool && String -> Bool doesNotHaveConsecutiveHyphens String owner Bool -> Bool -> Bool && String -> Bool doesNotBeginWithHyphen String owner Bool -> Bool -> Bool && String -> Bool doesNotEndWithHyphen String owner where isAlphaNumOrHyphen :: Char -> Bool isAlphaNumOrHyphen = (Char -> String -> Bool forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool `elem` Char '-' Char -> String -> String forall a. a -> [a] -> [a] : String alphaNum) doesNotHaveConsecutiveHyphens :: String -> Bool doesNotHaveConsecutiveHyphens = Bool -> Bool not (Bool -> Bool) -> (String -> Bool) -> String -> Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> String -> Bool forall a. Eq a => [a] -> [a] -> Bool isInfixOf String "--" doesNotBeginWithHyphen :: String -> Bool doesNotBeginWithHyphen = Bool -> Bool not (Bool -> Bool) -> (String -> Bool) -> String -> Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> String -> Bool forall a. Eq a => [a] -> [a] -> Bool isPrefixOf String "-" doesNotEndWithHyphen :: String -> Bool doesNotEndWithHyphen = Bool -> Bool not (Bool -> Bool) -> (String -> Bool) -> String -> Bool forall b c a. (b -> c) -> (a -> b) -> a -> c . String -> String -> Bool forall a. Eq a => [a] -> [a] -> Bool isSuffixOf String "-" isValidRepo :: String -> Bool isValidRepo :: String -> Bool isValidRepo String repo = Bool -> Bool not (String -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null String repo) Bool -> Bool -> Bool && String repo String -> [String] -> Bool forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool `notElem` [String ".", String ".."] Bool -> Bool -> Bool && (Char -> Bool) -> String -> Bool forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool all Char -> Bool isValid String repo where isValid :: Char -> Bool isValid = (Char -> String -> Bool forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool `elem` Char '_' Char -> String -> String forall a. a -> [a] -> [a] : Char '.' Char -> String -> String forall a. a -> [a] -> [a] : Char '-' Char -> String -> String forall a. a -> [a] -> [a] : String alphaNum) alphaNum :: [Char] alphaNum :: String alphaNum = [Char 'a'..Char 'z'] String -> String -> String forall a. [a] -> [a] -> [a] ++ [Char 'A'..Char 'Z'] String -> String -> String forall a. [a] -> [a] -> [a] ++ [Char '0'..Char '9'] data Ref = Ref {Ref -> String unRef :: String} instance FromValue Ref where fromValue :: Value -> Parser Ref fromValue = (String -> Parser Ref) -> Value -> Parser Ref forall a. (String -> Parser a) -> Value -> Parser a withString String -> Parser Ref parseRef parseRef :: String -> Parser Ref parseRef :: String -> Parser Ref parseRef String ref | String -> Bool isValidRef String ref = Ref -> Parser Ref forall (m :: * -> *) a. Monad m => a -> m a return (String -> Ref Ref String ref) | Bool otherwise = String -> Parser Ref forall (m :: * -> *) a. MonadFail m => String -> m a fail (String "invalid Git reference " String -> String -> String forall a. [a] -> [a] -> [a] ++ String -> String forall a. Show a => a -> String show String ref) data Path = Path {Path -> [String] unPath :: [FilePath]} instance FromValue Path where fromValue :: Value -> Parser Path fromValue = (String -> Parser Path) -> Value -> Parser Path forall a. (String -> Parser a) -> Value -> Parser a withString String -> Parser Path parsePath parsePath :: String -> Parser Path parsePath :: String -> Parser Path parsePath String path | Char '\\' Char -> String -> Bool forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool `elem` String path = String -> Parser Path forall (m :: * -> *) a. MonadFail m => String -> m a fail (String "rejecting '\\' in " String -> String -> String forall a. [a] -> [a] -> [a] ++ String -> String forall a. Show a => a -> String show String path String -> String -> String forall a. [a] -> [a] -> [a] ++ String ", please use '/' to separate path components") | Char ':' Char -> String -> Bool forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool `elem` String path = String -> Parser Path forall (m :: * -> *) a. MonadFail m => String -> m a fail (String "rejecting ':' in " String -> String -> String forall a. [a] -> [a] -> [a] ++ String -> String forall a. Show a => a -> String show String path) | String "/" String -> [String] -> Bool forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool `elem` [String] p = String -> Parser Path forall (m :: * -> *) a. MonadFail m => String -> m a fail (String "rejecting absolute path " String -> String -> String forall a. [a] -> [a] -> [a] ++ String -> String forall a. Show a => a -> String show String path) | String ".." String -> [String] -> Bool forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool `elem` [String] p = String -> Parser Path forall (m :: * -> *) a. MonadFail m => String -> m a fail (String "rejecting \"..\" in " String -> String -> String forall a. [a] -> [a] -> [a] ++ String -> String forall a. Show a => a -> String show String path) | Bool otherwise = Path -> Parser Path forall (m :: * -> *) a. Monad m => a -> m a return ([String] -> Path Path [String] p) where p :: [String] p = String -> [String] splitDirectories String path data Github = Github { Github -> String githubOwner :: String , Github -> String githubRepo :: String , Github -> String githubRef :: String , Github -> [String] githubPath :: [FilePath] } deriving (Github -> Github -> Bool (Github -> Github -> Bool) -> (Github -> Github -> Bool) -> Eq Github forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Github -> Github -> Bool $c/= :: Github -> Github -> Bool == :: Github -> Github -> Bool $c== :: Github -> Github -> Bool Eq, Int -> Github -> String -> String [Github] -> String -> String Github -> String (Int -> Github -> String -> String) -> (Github -> String) -> ([Github] -> String -> String) -> Show Github forall a. (Int -> a -> String -> String) -> (a -> String) -> ([a] -> String -> String) -> Show a showList :: [Github] -> String -> String $cshowList :: [Github] -> String -> String show :: Github -> String $cshow :: Github -> String showsPrec :: Int -> Github -> String -> String $cshowsPrec :: Int -> Github -> String -> String Show) toDefaultsGithub :: ParseGithub -> Github toDefaultsGithub :: ParseGithub -> Github toDefaultsGithub ParseGithub{Maybe Path Ref GithubRepo parseGithubPath :: Maybe Path parseGithubRef :: Ref parseGithubGithub :: GithubRepo parseGithubPath :: ParseGithub -> Maybe Path parseGithubRef :: ParseGithub -> Ref parseGithubGithub :: ParseGithub -> GithubRepo ..} = Github :: String -> String -> String -> [String] -> Github Github { githubOwner :: String githubOwner = GithubRepo -> String githubRepoOwner GithubRepo parseGithubGithub , githubRepo :: String githubRepo = GithubRepo -> String githubRepoName GithubRepo parseGithubGithub , githubRef :: String githubRef = Ref -> String unRef Ref parseGithubRef , githubPath :: [String] githubPath = [String] -> (Path -> [String]) -> Maybe Path -> [String] forall b a. b -> (a -> b) -> Maybe a -> b maybe [String ".hpack", String "defaults.yaml"] Path -> [String] unPath Maybe Path parseGithubPath } parseDefaultsGithubFromString :: String -> Parser ParseGithub parseDefaultsGithubFromString :: String -> Parser ParseGithub parseDefaultsGithubFromString String xs = case (Char -> Bool) -> String -> (String, String) forall a. (a -> Bool) -> [a] -> ([a], [a]) break (Char -> Char -> Bool forall a. Eq a => a -> a -> Bool == Char '@') String xs of (String github, Char '@' : String ref) -> GithubRepo -> Ref -> Maybe Path -> ParseGithub ParseGithub (GithubRepo -> Ref -> Maybe Path -> ParseGithub) -> Parser GithubRepo -> Parser (Ref -> Maybe Path -> ParseGithub) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> String -> Parser GithubRepo parseGithub String github Parser (Ref -> Maybe Path -> ParseGithub) -> Parser Ref -> Parser (Maybe Path -> ParseGithub) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> String -> Parser Ref parseRef String ref Parser (Maybe Path -> ParseGithub) -> Parser (Maybe Path) -> Parser ParseGithub forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Maybe Path -> Parser (Maybe Path) forall (f :: * -> *) a. Applicative f => a -> f a pure Maybe Path forall a. Maybe a Nothing (String, String) _ -> String -> Parser ParseGithub forall (m :: * -> *) a. MonadFail m => String -> m a fail (String "missing Git reference for " String -> String -> String forall a. [a] -> [a] -> [a] ++ String -> String forall a. Show a => a -> String show String xs String -> String -> String forall a. [a] -> [a] -> [a] ++ String ", the expected format is owner/repo@ref") data Local = Local { Local -> String localLocal :: String } deriving (Local -> Local -> Bool (Local -> Local -> Bool) -> (Local -> Local -> Bool) -> Eq Local forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Local -> Local -> Bool $c/= :: Local -> Local -> Bool == :: Local -> Local -> Bool $c== :: Local -> Local -> Bool Eq, Int -> Local -> String -> String [Local] -> String -> String Local -> String (Int -> Local -> String -> String) -> (Local -> String) -> ([Local] -> String -> String) -> Show Local forall a. (Int -> a -> String -> String) -> (a -> String) -> ([a] -> String -> String) -> Show a showList :: [Local] -> String -> String $cshowList :: [Local] -> String -> String show :: Local -> String $cshow :: Local -> String showsPrec :: Int -> Local -> String -> String $cshowsPrec :: Int -> Local -> String -> String Show, (forall x. Local -> Rep Local x) -> (forall x. Rep Local x -> Local) -> Generic Local forall x. Rep Local x -> Local forall x. Local -> Rep Local x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a $cto :: forall x. Rep Local x -> Local $cfrom :: forall x. Local -> Rep Local x Generic, Value -> Parser Local (Value -> Parser Local) -> FromValue Local forall a. (Value -> Parser a) -> FromValue a fromValue :: Value -> Parser Local $cfromValue :: Value -> Parser Local FromValue) data Defaults = DefaultsLocal Local | DefaultsGithub Github deriving (Defaults -> Defaults -> Bool (Defaults -> Defaults -> Bool) -> (Defaults -> Defaults -> Bool) -> Eq Defaults forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: Defaults -> Defaults -> Bool $c/= :: Defaults -> Defaults -> Bool == :: Defaults -> Defaults -> Bool $c== :: Defaults -> Defaults -> Bool Eq, Int -> Defaults -> String -> String [Defaults] -> String -> String Defaults -> String (Int -> Defaults -> String -> String) -> (Defaults -> String) -> ([Defaults] -> String -> String) -> Show Defaults forall a. (Int -> a -> String -> String) -> (a -> String) -> ([a] -> String -> String) -> Show a showList :: [Defaults] -> String -> String $cshowList :: [Defaults] -> String -> String show :: Defaults -> String $cshow :: Defaults -> String showsPrec :: Int -> Defaults -> String -> String $cshowsPrec :: Int -> Defaults -> String -> String Show) instance FromValue Defaults where fromValue :: Value -> Parser Defaults fromValue Value v = case Value v of String Text s -> Github -> Defaults DefaultsGithub (Github -> Defaults) -> (ParseGithub -> Github) -> ParseGithub -> Defaults forall b c a. (b -> c) -> (a -> b) -> a -> c . ParseGithub -> Github toDefaultsGithub (ParseGithub -> Defaults) -> Parser ParseGithub -> Parser Defaults forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> String -> Parser ParseGithub parseDefaultsGithubFromString (Text -> String T.unpack Text s) Object Object o | Text "local" Text -> Object -> Bool forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool `member` Object o -> Local -> Defaults DefaultsLocal (Local -> Defaults) -> Parser Local -> Parser Defaults forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Value -> Parser Local forall a. FromValue a => Value -> Parser a fromValue Value v Object Object o | Text "github" Text -> Object -> Bool forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool `member` Object o -> Github -> Defaults DefaultsGithub (Github -> Defaults) -> (ParseGithub -> Github) -> ParseGithub -> Defaults forall b c a. (b -> c) -> (a -> b) -> a -> c . ParseGithub -> Github toDefaultsGithub (ParseGithub -> Defaults) -> Parser ParseGithub -> Parser Defaults forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Value -> Parser ParseGithub forall a. FromValue a => Value -> Parser a fromValue Value v Object Object _ -> String -> Parser Defaults forall (m :: * -> *) a. MonadFail m => String -> m a fail String "neither key \"github\" nor key \"local\" present" Value _ -> String -> Value -> Parser Defaults forall a. String -> Value -> Parser a typeMismatch String "Object or String" Value v