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