{-# 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. 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
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 = 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) = forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"invalid owner name " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
owner)
  | Bool -> Bool
not (String -> Bool
isValidRepo String
repo) = forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"invalid repository name " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
repo)
  | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String -> GithubRepo
GithubRepo String
owner String
repo)
  where
    (String
owner, String
repo) = forall a. Int -> [a] -> [a]
drop Int
1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'/') String
github

isValidOwner :: String -> Bool
isValidOwner :: String -> Bool
isValidOwner String
owner =
     Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
owner)
  Bool -> Bool -> 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 = (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Char
'-' forall a. a -> [a] -> [a]
: String
alphaNum)
    doesNotHaveConsecutiveHyphens :: String -> Bool
doesNotHaveConsecutiveHyphens = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> Bool
isInfixOf String
"--"
    doesNotBeginWithHyphen :: String -> Bool
doesNotBeginWithHyphen = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
"-"
    doesNotEndWithHyphen :: String -> Bool
doesNotEndWithHyphen = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf String
"-"

isValidRepo :: String -> Bool
isValidRepo :: String -> Bool
isValidRepo String
repo =
     Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
repo)
  Bool -> Bool -> Bool
&& String
repo forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String
".", String
".."]
  Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isValid String
repo
  where
    isValid :: Char -> Bool
isValid = (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Char
'_' forall a. a -> [a] -> [a]
: Char
'.' forall a. a -> [a] -> [a]
: Char
'-' forall a. a -> [a] -> [a]
: String
alphaNum)

alphaNum :: [Char]
alphaNum :: String
alphaNum = [Char
'a'..Char
'z'] forall a. [a] -> [a] -> [a]
++ [Char
'A'..Char
'Z'] 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 = 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 = forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Ref
Ref String
ref)
  | Bool
otherwise = forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"invalid Git reference " forall a. [a] -> [a] -> [a]
++ 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 = 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
'\\' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
path = forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"rejecting '\\' in " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
path forall a. [a] -> [a] -> [a]
++ String
", please use '/' to separate path components")
  | Char
':' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
path = forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"rejecting ':' in " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
path)
  | String
"/" forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
p = forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"rejecting absolute path " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
path)
  | String
".." forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
p = forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"rejecting \"..\" in " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
path)
  | Bool
otherwise = 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
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 -> ShowS
[Github] -> ShowS
Github -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Github] -> ShowS
$cshowList :: [Github] -> ShowS
show :: Github -> String
$cshow :: Github -> String
showsPrec :: Int -> Github -> ShowS
$cshowsPrec :: Int -> Github -> ShowS
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 {
    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 = 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 forall a. (a -> Bool) -> [a] -> ([a], [a])
break (forall a. Eq a => a -> a -> Bool
== Char
'@') String
xs of
  (String
github, Char
'@' : String
ref) -> GithubRepo -> Ref -> Maybe Path -> ParseGithub
ParseGithub forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Parser GithubRepo
parseGithub String
github forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String -> Parser Ref
parseRef String
ref forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
  (String, String)
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"missing Git reference for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
xs forall a. [a] -> [a] -> [a]
++ String
", the expected format is owner/repo@ref")

data Local = Local {
  Local -> String
localLocal :: String
} deriving (Local -> Local -> Bool
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 -> ShowS
[Local] -> ShowS
Local -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Local] -> ShowS
$cshowList :: [Local] -> ShowS
show :: Local -> String
$cshow :: Local -> String
showsPrec :: Int -> Local -> ShowS
$cshowsPrec :: Int -> Local -> ShowS
Show, 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
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
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 -> ShowS
[Defaults] -> ShowS
Defaults -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Defaults] -> ShowS
$cshowList :: [Defaults] -> ShowS
show :: Defaults -> String
$cshow :: Defaults -> String
showsPrec :: Int -> Defaults -> ShowS
$cshowsPrec :: Int -> Defaults -> ShowS
Show)

instance FromValue Defaults where
  fromValue :: Value -> Parser Defaults
fromValue Value
v = case Value
v of
    String Text
s -> Github -> Defaults
DefaultsGithub forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseGithub -> Github
toDefaultsGithub 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 | Key
"local" forall a. Key -> KeyMap a -> Bool
`member` Object
o -> Local -> Defaults
DefaultsLocal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromValue a => Value -> Parser a
fromValue Value
v
    Object Object
o | Key
"github" forall a. Key -> KeyMap a -> Bool
`member` Object
o -> Github -> Defaults
DefaultsGithub forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseGithub -> Github
toDefaultsGithub forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromValue a => Value -> Parser a
fromValue Value
v
    Object Object
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"neither key \"github\" nor key \"local\" present"
    Value
_ -> forall a. String -> Value -> Parser a
typeMismatch String
"Object or String" Value
v