{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Stack.Templates
( templatesCmd
, templatesHelp
) where
import qualified Data.ByteString.Lazy as LB
import qualified Data.Text as T
import Network.HTTP.StackClient
( HttpException (..), getResponseBody, httpLbs, parseUrlThrow
, setGitHubHeaders
)
import Stack.Prelude
import Stack.Runners ( ShouldReexec (..), withConfig )
import Stack.Types.Runner ( Runner )
data TemplatesPrettyException
= DownloadTemplatesHelpFailed !HttpException
| TemplatesHelpEncodingInvalid !String !UnicodeException
deriving Typeable
deriving instance Show TemplatesPrettyException
instance Pretty TemplatesPrettyException where
pretty :: TemplatesPrettyException -> StyleDoc
pretty (DownloadTemplatesHelpFailed HttpException
err) =
StyleDoc
"[S-8143]"
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
[ String -> StyleDoc
flow String
"Stack failed to download the help for"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"stack templates" forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"While downloading, Stack encountered the following error:"
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
string (forall e. Exception e => e -> String
displayException HttpException
err)
pretty (TemplatesHelpEncodingInvalid String
url UnicodeException
err) =
StyleDoc
"[S-6670]"
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
forall a. Semigroup a => a -> a -> a
<> [StyleDoc] -> StyleDoc
fillSep
[ String -> StyleDoc
flow String
"Stack failed to decode the help for"
, Style -> StyleDoc -> StyleDoc
style Style
Shell StyleDoc
"stack templates"
, String -> StyleDoc
flow String
"downloaded from"
, Style -> StyleDoc -> StyleDoc
style Style
Url (forall a. IsString a => String -> a
fromString String
url) forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
]
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"While decoding, Stack encountered the following error:"
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
string (forall e. Exception e => e -> String
displayException UnicodeException
err)
instance Exception TemplatesPrettyException
templatesCmd :: () -> RIO Runner ()
templatesCmd :: () -> RIO Runner ()
templatesCmd () = forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
NoReexec forall env. HasTerm env => RIO env ()
templatesHelp
templatesHelp :: HasTerm env => RIO env ()
templatesHelp :: forall env. HasTerm env => RIO env ()
templatesHelp = do
let url :: String
url = String
defaultTemplatesHelpUrl
Request
req <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Request -> Request
setGitHubHeaders (forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow String
url)
Response LByteString
resp <- forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch
(forall (m :: * -> *).
MonadIO m =>
Request -> m (Response LByteString)
httpLbs Request
req)
(forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM forall b c a. (b -> c) -> (a -> b) -> a -> c
. HttpException -> TemplatesPrettyException
DownloadTemplatesHelpFailed)
case ByteString -> Either UnicodeException Text
decodeUtf8' forall a b. (a -> b) -> a -> b
$ LByteString -> ByteString
LB.toStrict forall a b. (a -> b) -> a -> b
$ forall a. Response a -> a
getResponseBody Response LByteString
resp of
Left UnicodeException
err -> forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM forall a b. (a -> b) -> a -> b
$ String -> UnicodeException -> TemplatesPrettyException
TemplatesHelpEncodingInvalid String
url UnicodeException
err
Right Text
txt -> forall env (m :: * -> *).
(HasCallStack, HasTerm env, MonadReader env m, MonadIO m) =>
StyleDoc -> m ()
prettyInfo (String -> StyleDoc
string forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
txt)
defaultTemplatesHelpUrl :: String
defaultTemplatesHelpUrl :: String
defaultTemplatesHelpUrl =
String
"https://raw.githubusercontent.com/commercialhaskell/stack-templates/master/STACK_HELP.md"