{-# 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.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 Typeable

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
  Request
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)
  Response LByteString
resp <- RIO env (Response LByteString)
-> (HttpException -> RIO env (Response LByteString))
-> RIO env (Response LByteString)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
catch
    (Request -> RIO env (Response LByteString)
forall (m :: * -> *).
MonadIO m =>
Request -> m (Response LByteString)
httpLbs Request
req)
    (TemplatesPrettyException -> RIO env (Response LByteString)
forall e (m :: * -> *) a.
(Exception e, MonadThrow m, Pretty e) =>
e -> m a
prettyThrowM (TemplatesPrettyException -> RIO env (Response LByteString))
-> (HttpException -> TemplatesPrettyException)
-> HttpException
-> RIO env (Response LByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HttpException -> TemplatesPrettyException
DownloadTemplatesHelpFailed)
  case ByteString -> Either UnicodeException Text
decodeUtf8' (ByteString -> Either UnicodeException Text)
-> ByteString -> Either UnicodeException Text
forall a b. (a -> b) -> a -> b
$ LByteString -> ByteString
LB.toStrict (LByteString -> ByteString) -> LByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Response LByteString -> LByteString
forall a. Response a -> a
getResponseBody Response LByteString
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"