{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Stack.Types.TemplateName
( TemplateName
, RepoTemplatePath (..)
, RepoService (..)
, TemplatePath (..)
, mkTemplateName
, templateName
, templatePath
, parseTemplateNameFromString
, parseRepoPathWithService
, templateNameArgument
, templateParamArgument
) where
import Data.Aeson (FromJSON (..), withText)
import qualified Data.Text as T
import Language.Haskell.TH
import Network.HTTP.StackClient (parseRequest)
import qualified Options.Applicative as O
import Path
import Path.Internal
import Stack.Prelude
data TemplateName = TemplateName !Text !TemplatePath
deriving (Ord,Eq,Show)
data TemplatePath = AbsPath (Path Abs File)
| RelPath (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 <$> parseRelFile hsf
]
expected = "Expected a template like: foo or foo.hsfiles or\
\ https://example.com/foo.hsfiles or github:user/foo"
mkTemplateName :: String -> Q Exp
mkTemplateName s =
case parseTemplateNameFromString s of
Left{} -> runIO $ throwString ("Invalid template name: " ++ show s)
Right (TemplateName (T.unpack -> prefix) p) ->
[|TemplateName (T.pack prefix) $(pn)|]
where pn =
case p of
AbsPath (Path fp) -> [|AbsPath (Path fp)|]
RelPath (Path fp) -> [|RelPath (Path fp)|]
UrlPath fp -> [|UrlPath fp|]
RepoPath (RepoTemplatePath sv u t) ->
case sv of
Github -> [|RepoPath $ RepoTemplatePath Github u t|]
Gitlab -> [|RepoPath $ RepoTemplatePath Gitlab u t|]
Bitbucket -> [|RepoPath $ RepoTemplatePath Bitbucket u t|]
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