    {-# 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 {
      parseGithubGithub :: GithubRepo
    , parseGithubRef :: Ref
    , parseGithubPath :: Maybe Path
    } deriving (Generic, FromValue)

    data GithubRepo = GithubRepo {
      githubRepoOwner :: String
    , githubRepoName :: String
    }

    instance FromValue GithubRepo where
      fromValue = withString parseGithub

    parseGithub :: String -> Parser GithubRepo
    parseGithub github
      | not (isValidOwner owner) = fail ("invalid owner name " ++ show owner)
      | not (isValidRepo repo) = fail ("invalid repository name " ++ show repo)
      | otherwise = return (GithubRepo owner repo)
      where
        (owner, repo) = drop 1 <$> break (== '/') github

    isValidOwner :: String -> Bool
    isValidOwner owner =
         not (null owner)
      && all isAlphaNumOrHyphen owner
      && doesNotHaveConsecutiveHyphens owner
      && doesNotBeginWithHyphen owner
      && doesNotEndWithHyphen owner
      where
        isAlphaNumOrHyphen = (`elem` '-' : alphaNum)
        doesNotHaveConsecutiveHyphens = not . isInfixOf "--"
        doesNotBeginWithHyphen = not . isPrefixOf "-"
        doesNotEndWithHyphen = not . isSuffixOf "-"

    isValidRepo :: String -> Bool
    isValidRepo repo =
         not (null repo)
      && repo `notElem` [".", ".."]
      && all isValid repo
      where
        isValid = (`elem` '_' : '.' : '-' : alphaNum)

    alphaNum :: [Char]
    alphaNum = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9']

    data Ref = Ref {unRef :: String}

    instance FromValue Ref where
      fromValue = withString parseRef

    parseRef :: String -> Parser Ref
    parseRef ref
      | isValidRef ref = return (Ref ref)
      | otherwise = fail ("invalid Git reference " ++ show ref)

    data Path = Path {unPath :: [FilePath]}

    instance FromValue Path where
      fromValue = withString parsePath

    parsePath :: String -> Parser Path
    parsePath path
      | '\\' `elem` path = fail ("rejecting '\\' in " ++ show path ++ ", please use '/' to separate path components")
      | ':' `elem` path = fail ("rejecting ':' in " ++ show path)
      | "/" `elem` p = fail ("rejecting absolute path " ++ show path)
      | ".." `elem` p = fail ("rejecting \"..\" in " ++ show path)
      | otherwise = return (Path p)
      where
        p = splitDirectories path

    data Github = Github {
      githubOwner :: String
    , githubRepo :: String
    , githubRef :: String
    , githubPath :: [FilePath]
    } deriving (Eq, Show)

    toDefaultsGithub :: ParseGithub -> Github
    toDefaultsGithub ParseGithub{..} = Github {
        githubOwner = githubRepoOwner parseGithubGithub
      , githubRepo = githubRepoName parseGithubGithub
      , githubRef = unRef parseGithubRef
      , githubPath = maybe [".hpack", "defaults.yaml"] unPath parseGithubPath
      }

    parseDefaultsGithubFromString :: String -> Parser ParseGithub
    parseDefaultsGithubFromString xs = case break (== '@') xs of
      (github, '@' : ref) -> ParseGithub <$> parseGithub github <*> parseRef ref <*> pure Nothing
      _ -> fail ("missing Git reference for " ++ show xs ++ ", the expected format is owner/repo@ref")

    data Local = Local {
      localLocal :: String
    } deriving (Eq, Show, Generic, FromValue)

    data Defaults = DefaultsLocal Local | DefaultsGithub Github
      deriving (Eq, Show)

    instance FromValue Defaults where
      fromValue v = case v of
        String s -> DefaultsGithub . toDefaultsGithub <$> parseDefaultsGithubFromString (T.unpack s)
        Object o | "local" `member` o -> DefaultsLocal <$> fromValue v
        Object o | "github" `member` o -> DefaultsGithub . toDefaultsGithub <$> fromValue v
        Object _ -> fail "neither key \"github\" nor key \"local\" present"
        _ -> typeMismatch "Object or String" v