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