{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Functions related to Stack's @templates@ command.

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 )

-- | Type representing \'pretty\' exceptions thrown by functions exported by the

-- "Stack.Templates" module.

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

-- | Function underlying the @stack templates@ command. Display instructions for

-- how to use templates.

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

-- | Display help for the templates command.

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)

-- | Default web URL to get the `stack templates` help output.

defaultTemplatesHelpUrl :: String
defaultTemplatesHelpUrl :: String
defaultTemplatesHelpUrl =
  String
"https://raw.githubusercontent.com/commercialhaskell/stack-templates/master/STACK_HELP.md"