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

{-|
Module      : Stack.Templates
Description : Functions related to Stack's @templates@ command.
License     : BSD-3-Clause

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

module Stack.Templates
  ( templatesCmd
  , templatesHelp
  ) where

import qualified Data.ByteString.Lazy as LB
import qualified Data.Text.IO 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 instance Show TemplatesPrettyException

instance Pretty TemplatesPrettyException where
  pretty :: TemplatesPrettyException -> StyleDoc
pretty (DownloadTemplatesHelpFailed HttpException
err) =
    StyleDoc
"[S-8143]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
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" StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         ]
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"While downloading, Stack encountered the following error:"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
string (HttpException -> String
forall e. Exception e => e -> String
displayException HttpException
err)
  pretty (TemplatesHelpEncodingInvalid String
url UnicodeException
err) =
    StyleDoc
"[S-6670]"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
line
    StyleDoc -> StyleDoc -> StyleDoc
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 (String -> StyleDoc
forall a. IsString a => String -> a
fromString String
url) StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
"."
         ]
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
flow String
"While decoding, Stack encountered the following error:"
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> StyleDoc
blankLine
    StyleDoc -> StyleDoc -> StyleDoc
forall a. Semigroup a => a -> a -> a
<> String -> StyleDoc
string (UnicodeException -> 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 () = ShouldReexec -> RIO Config () -> RIO Runner ()
forall a. ShouldReexec -> RIO Config a -> RIO Runner a
withConfig ShouldReexec
NoReexec RIO Config ()
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
  req <- (Request -> Request) -> RIO env Request -> RIO env Request
forall a b. (a -> b) -> RIO env a -> RIO env b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Request -> Request
setGitHubHeaders (String -> RIO env Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow String
url)
  resp <- catch
    (httpLbs req)
    (prettyThrowM . DownloadTemplatesHelpFailed)
  case decodeUtf8' $ LB.toStrict $ getResponseBody resp of
    Left UnicodeException
err -> TemplatesPrettyException -> RIO env ()
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (TemplatesPrettyException -> RIO env ())
-> TemplatesPrettyException -> RIO env ()
forall a b. (a -> b) -> a -> b
$ String -> UnicodeException -> TemplatesPrettyException
TemplatesHelpEncodingInvalid String
url UnicodeException
err
    Right Text
txt -> IO () -> RIO env ()
forall a. IO a -> RIO env a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> RIO env ()) -> IO () -> RIO env ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn 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"