{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Stack.Types.TemplateName
( TemplateName
, RepoTemplatePath (..)
, RepoService (..)
, TemplatePath (..)
, templateName
, templatePath
, parseTemplateNameFromString
, parseRepoPathWithService
, templateNameArgument
, templateParamArgument
, defaultTemplateName
) where
import Data.Aeson (FromJSON (..), withText)
import qualified Data.Text as T
import Network.HTTP.StackClient (parseRequest)
import qualified Options.Applicative as O
import Path
import Stack.Prelude
data TemplateName = TemplateName !Text !TemplatePath
deriving (Ord,Eq,Show)
data TemplatePath = AbsPath (Path Abs File)
| RelPath String (Path Rel File)
| UrlPath String
| RepoPath RepoTemplatePath
deriving (Eq, Ord, Show)
data RepoTemplatePath = RepoTemplatePath
{ rtpService :: RepoService
, rtpUser :: Text
, rtpTemplate :: Text
}
deriving (Eq, Ord, Show)
data RepoService = Github | Gitlab | Bitbucket
deriving (Eq, Ord, Show)
instance FromJSON TemplateName where
parseJSON = withText "TemplateName" $
either fail return . parseTemplateNameFromString . T.unpack
templateNameArgument :: O.Mod O.ArgumentFields TemplateName
-> O.Parser TemplateName
templateNameArgument =
O.argument
(do string <- O.str
either O.readerError return (parseTemplateNameFromString string))
templateParamArgument :: O.Mod O.OptionFields (Text,Text)
-> O.Parser (Text,Text)
templateParamArgument =
O.option
(do string <- O.str
either O.readerError return (parsePair string))
where
parsePair :: String -> Either String (Text, Text)
parsePair s =
case break (==':') s of
(key,':':value@(_:_)) -> Right (T.pack key, T.pack value)
_ -> Left ("Expected key:value format for argument: " <> s)
parseTemplateNameFromString :: String -> Either String TemplateName
parseTemplateNameFromString fname =
case T.stripSuffix ".hsfiles" (T.pack fname) of
Nothing -> parseValidFile (T.pack fname) (fname <> ".hsfiles") fname
Just prefix -> parseValidFile prefix fname fname
where
parseValidFile prefix hsf orig = maybe (Left expected) Right
$ asum (validParses prefix hsf orig)
validParses prefix hsf orig =
[ TemplateName prefix . RepoPath <$> parseRepoPath hsf
, TemplateName (T.pack orig) . UrlPath <$> (parseRequest orig *> Just orig)
, TemplateName prefix . AbsPath <$> parseAbsFile hsf
, TemplateName prefix . RelPath hsf <$> parseRelFile hsf
]
expected = "Expected a template like: foo or foo.hsfiles or\
\ https://example.com/foo.hsfiles or github:user/foo"
defaultTemplateName :: TemplateName
defaultTemplateName =
case parseTemplateNameFromString "new-template" of
Left s -> error $ "Bug in Stack codebase, cannot parse default template name: " ++ s
Right x -> x
templateName :: TemplateName -> Text
templateName (TemplateName prefix _) = prefix
templatePath :: TemplateName -> TemplatePath
templatePath (TemplateName _ fp) = fp
defaultRepoUserForService :: RepoService -> Maybe Text
defaultRepoUserForService Github = Just "commercialhaskell"
defaultRepoUserForService _ = Nothing
parseRepoPath :: String -> Maybe RepoTemplatePath
parseRepoPath s =
case T.splitOn ":" (T.pack s) of
["github" , rest] -> parseRepoPathWithService Github rest
["gitlab" , rest] -> parseRepoPathWithService Gitlab rest
["bitbucket" , rest] -> parseRepoPathWithService Bitbucket rest
_ -> Nothing
parseRepoPathWithService :: RepoService -> Text -> Maybe RepoTemplatePath
parseRepoPathWithService service path =
case T.splitOn "/" path of
[user, name] -> Just $ RepoTemplatePath service user name
[name] -> do
repoUser <- defaultRepoUserForService service
Just $ RepoTemplatePath service repoUser name
_ -> Nothing