{-# 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