{-|
Module      : Headroom.Command.Init
Description : Logic for Init command
Copyright   : (c) 2019-2020 Vaclav Svejcar
License     : BSD-3
Maintainer  : vaclav.svejcar@gmail.com
Stability   : experimental
Portability : POSIX

Logic for the @init@ command, used to generate initial configuration boilerplate
for Headroom.
-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Headroom.Command.Init
  ( commandInit
  , doesAppConfigExist
  , findSupportedFileTypes
  )
where

import           Headroom.AppConfig             ( AppConfig(..)
                                                , prettyPrintAppConfig
                                                )
import           Headroom.Command.Init.Env
import           Headroom.Command.Shared        ( bootstrap )
import           Headroom.Embedded              ( licenseTemplate )
import           Headroom.FileSystem            ( fileExtension
                                                , findFiles
                                                )
import           Headroom.FileType              ( FileType
                                                , fileTypeByExt
                                                )
import           Headroom.Global                ( TemplateType )
import           Headroom.License               ( License(..) )
import           Headroom.Template              ( templateExtensions )
import           Headroom.Types                 ( HeadroomError(..)
                                                , InitCommandError(..)
                                                )
import           Headroom.UI.Progress           ( Progress(..)
                                                , zipWithProgress
                                                )
import           RIO
import qualified RIO.Char                      as C
import           RIO.Directory                  ( createDirectory
                                                , doesFileExist
                                                , getCurrentDirectory
                                                )
import           RIO.FilePath                   ( (</>) )
import qualified RIO.HashMap                   as HM
import qualified RIO.List                      as L
import qualified RIO.NonEmpty                  as NE
import qualified RIO.Text                      as T


env' :: InitOptions -> LogFunc -> IO Env
env' :: InitOptions -> LogFunc -> IO Env
env' opts :: InitOptions
opts logFunc :: LogFunc
logFunc = do
  FilePath
currentDir <- IO FilePath
forall (m :: * -> *). MonadIO m => m FilePath
getCurrentDirectory
  let paths :: Paths
paths = $WPaths :: FilePath -> FilePath -> FilePath -> Paths
Paths { pCurrentDir :: FilePath
pCurrentDir   = FilePath
currentDir
                    , pConfigFile :: FilePath
pConfigFile   = ".headroom.yaml"
                    , pTemplatesDir :: FilePath
pTemplatesDir = "headroom-templates"
                    }
  Env -> IO Env
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Env -> IO Env) -> Env -> IO Env
forall a b. (a -> b) -> a -> b
$ $WEnv :: LogFunc -> InitOptions -> Paths -> Env
Env { envLogFunc :: LogFunc
envLogFunc = LogFunc
logFunc, envInitOptions :: InitOptions
envInitOptions = InitOptions
opts, envPaths :: Paths
envPaths = Paths
paths }

-- | Handler for /Init/ command.
commandInit :: InitOptions -- ^ /Init/ command options
            -> IO ()       -- ^ execution result
commandInit :: InitOptions -> IO ()
commandInit opts :: InitOptions
opts = (LogFunc -> IO Env) -> Bool -> RIO Env () -> IO ()
forall env a. (LogFunc -> IO env) -> Bool -> RIO env a -> IO a
bootstrap (InitOptions -> LogFunc -> IO Env
env' InitOptions
opts) Bool
False (RIO Env () -> IO ()) -> RIO Env () -> IO ()
forall a b. (a -> b) -> a -> b
$ RIO Env Bool
forall env. (HasLogFunc env, HasPaths env) => RIO env Bool
doesAppConfigExist RIO Env Bool -> (Bool -> RIO Env ()) -> RIO Env ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  False -> do
    [FileType]
fileTypes <- RIO Env [FileType]
forall env.
(HasInitOptions env, HasLogFunc env) =>
RIO env [FileType]
findSupportedFileTypes
    RIO Env ()
forall env. (HasLogFunc env, HasPaths env) => RIO env ()
makeTemplatesDir
    [FileType] -> RIO Env ()
forall env.
(HasInitOptions env, HasLogFunc env, HasPaths env) =>
[FileType] -> RIO env ()
createTemplates [FileType]
fileTypes
    RIO Env ()
forall env.
(HasInitOptions env, HasLogFunc env, HasPaths env) =>
RIO env ()
createConfigFile
  True -> HeadroomError -> RIO Env ()
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (HeadroomError -> RIO Env ()) -> HeadroomError -> RIO Env ()
forall a b. (a -> b) -> a -> b
$ InitCommandError -> HeadroomError
InitCommandError InitCommandError
AppConfigAlreadyExists

-- | Recursively scans provided source paths for known file types for which
-- templates can be generated.
findSupportedFileTypes :: (HasInitOptions env, HasLogFunc env)
                       => RIO env [FileType]
findSupportedFileTypes :: RIO env [FileType]
findSupportedFileTypes = do
  InitOptions
opts      <- Getting InitOptions env InitOptions -> RIO env InitOptions
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting InitOptions env InitOptions
forall env. HasInitOptions env => Lens' env InitOptions
initOptionsL
  [FileType]
fileTypes <- do
    [[FilePath]]
allFiles <- (FilePath -> RIO env [FilePath])
-> [FilePath] -> RIO env [[FilePath]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\path :: FilePath
path -> FilePath -> (FilePath -> Bool) -> RIO env [FilePath]
forall (m :: * -> *).
MonadIO m =>
FilePath -> (FilePath -> Bool) -> m [FilePath]
findFiles FilePath
path (Bool -> FilePath -> Bool
forall a b. a -> b -> a
const Bool
True)) (InitOptions -> [FilePath]
ioSourcePaths InitOptions
opts)
    let allFileTypes :: [Maybe FileType]
allFileTypes = (FilePath -> Maybe FileType) -> [FilePath] -> [Maybe FileType]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FilePath -> Maybe Text
fileExtension (FilePath -> Maybe Text)
-> (Text -> Maybe FileType) -> FilePath -> Maybe FileType
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Text -> Maybe FileType
fileTypeByExt) ([[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[FilePath]]
allFiles)
    [FileType] -> RIO env [FileType]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([FileType] -> RIO env [FileType])
-> [FileType] -> RIO env [FileType]
forall a b. (a -> b) -> a -> b
$ [FileType] -> [FileType]
forall a. Eq a => [a] -> [a]
L.nub ([FileType] -> [FileType])
-> ([Maybe FileType] -> [FileType])
-> [Maybe FileType]
-> [FileType]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe FileType] -> [FileType]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe FileType] -> [FileType]) -> [Maybe FileType] -> [FileType]
forall a b. (a -> b) -> a -> b
$ [Maybe FileType]
allFileTypes
  case [FileType]
fileTypes of
    [] -> HeadroomError -> RIO env [FileType]
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (HeadroomError -> RIO env [FileType])
-> HeadroomError -> RIO env [FileType]
forall a b. (a -> b) -> a -> b
$ InitCommandError -> HeadroomError
InitCommandError InitCommandError
NoSourcePaths
    _  -> do
      Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ "Found supported file types: " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> [FileType] -> Utf8Builder
forall a. Show a => a -> Utf8Builder
displayShow [FileType]
fileTypes
      [FileType] -> RIO env [FileType]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [FileType]
fileTypes

createTemplates :: (HasInitOptions env, HasLogFunc env, HasPaths env)
                => [FileType]
                -> RIO env ()
createTemplates :: [FileType] -> RIO env ()
createTemplates fileTypes :: [FileType]
fileTypes = do
  InitOptions
opts  <- Getting InitOptions env InitOptions -> RIO env InitOptions
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting InitOptions env InitOptions
forall env. HasInitOptions env => Lens' env InitOptions
initOptionsL
  Paths
paths <- Getting Paths env Paths -> RIO env Paths
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Paths env Paths
forall env. HasPaths env => Lens' env Paths
pathsL
  let templatesDir :: FilePath
templatesDir = Paths -> FilePath
pCurrentDir Paths
paths FilePath -> FilePath -> FilePath
</> Paths -> FilePath
pTemplatesDir Paths
paths
  ((Progress, License) -> RIO env ())
-> [(Progress, License)] -> RIO env ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(p :: Progress
p, l :: License
l) -> FilePath -> License -> Progress -> RIO env ()
forall env.
HasLogFunc env =>
FilePath -> License -> Progress -> RIO env ()
createTemplate FilePath
templatesDir License
l Progress
p)
        ([License] -> [(Progress, License)]
forall a. [a] -> [(Progress, a)]
zipWithProgress ([License] -> [(Progress, License)])
-> [License] -> [(Progress, License)]
forall a b. (a -> b) -> a -> b
$ (FileType -> License) -> [FileType] -> [License]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (LicenseType -> FileType -> License
License (InitOptions -> LicenseType
ioLicenseType InitOptions
opts)) [FileType]
fileTypes)

createTemplate :: (HasLogFunc env)
               => FilePath
               -> License
               -> Progress
               -> RIO env ()
createTemplate :: FilePath -> License -> Progress -> RIO env ()
createTemplate templatesDir :: FilePath
templatesDir license :: License
license@(License _ fileType :: FileType
fileType) progress :: Progress
progress = do
  let extension :: Text
extension = NonEmpty Text -> Text
forall a. NonEmpty a -> a
NE.head (NonEmpty Text -> Text) -> NonEmpty Text -> Text
forall a b. (a -> b) -> a -> b
$ Proxy TemplateType -> NonEmpty Text
forall t (proxy :: * -> *). Template t => proxy t -> NonEmpty Text
templateExtensions (Proxy TemplateType
forall k (t :: k). Proxy t
Proxy :: Proxy TemplateType)
      file :: FilePath
file = ((Char -> Char) -> FilePath -> FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Char -> Char
C.toLower (FilePath -> FilePath)
-> (FileType -> FilePath) -> FileType -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileType -> FilePath
forall a. Show a => a -> FilePath
show (FileType -> FilePath) -> FileType -> FilePath
forall a b. (a -> b) -> a -> b
$ FileType
fileType) FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> "." FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack Text
extension
      filePath :: FilePath
filePath  = FilePath
templatesDir FilePath -> FilePath -> FilePath
</> FilePath
file
      template :: Text
template  = License -> Text
forall a. IsString a => License -> a
licenseTemplate License
license
  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ [Utf8Builder] -> Utf8Builder
forall a. Monoid a => [a] -> a
mconcat
    [Progress -> Utf8Builder
forall a. Display a => a -> Utf8Builder
display Progress
progress, " Creating template file in ", FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString FilePath
filePath]
  FilePath -> Text -> RIO env ()
forall (m :: * -> *). MonadIO m => FilePath -> Text -> m ()
writeFileUtf8 FilePath
filePath Text
template

createConfigFile :: (HasInitOptions env, HasLogFunc env, HasPaths env)
                 => RIO env ()
createConfigFile :: RIO env ()
createConfigFile = do
  InitOptions
opts  <- Getting InitOptions env InitOptions -> RIO env InitOptions
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting InitOptions env InitOptions
forall env. HasInitOptions env => Lens' env InitOptions
initOptionsL
  Paths
paths <- Getting Paths env Paths -> RIO env Paths
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Paths env Paths
forall env. HasPaths env => Lens' env Paths
pathsL
  let filePath :: FilePath
filePath = Paths -> FilePath
pCurrentDir Paths
paths FilePath -> FilePath -> FilePath
</> Paths -> FilePath
pConfigFile Paths
paths
      content :: Text
content  = AppConfig -> Text
prettyPrintAppConfig (AppConfig -> Text) -> AppConfig -> Text
forall a b. (a -> b) -> a -> b
$ InitOptions -> Paths -> AppConfig
appConfig InitOptions
opts Paths
paths
  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ "Creating YAML config file in " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString FilePath
filePath
  FilePath -> Text -> RIO env ()
forall (m :: * -> *). MonadIO m => FilePath -> Text -> m ()
writeFileUtf8 FilePath
filePath Text
content
 where
  variables :: HashMap Text Text
variables = [(Text, Text)] -> HashMap Text Text
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList
    [ ("author" , "John Smith")
    , ("email"  , "john.smith@example.com")
    , ("project", "My project")
    , ("year"   , "2020")
    ]
  appConfig :: InitOptions -> Paths -> AppConfig
appConfig opts :: InitOptions
opts paths :: Paths
paths = AppConfig
forall a. Monoid a => a
mempty { acSourcePaths :: [FilePath]
acSourcePaths   = InitOptions -> [FilePath]
ioSourcePaths InitOptions
opts
                                , acTemplatePaths :: [FilePath]
acTemplatePaths = [Paths -> FilePath
pTemplatesDir Paths
paths]
                                , acVariables :: HashMap Text Text
acVariables     = HashMap Text Text
variables
                                }

-- | Checks whether application config file already exists.
doesAppConfigExist :: (HasLogFunc env, HasPaths env) => RIO env Bool
doesAppConfigExist :: RIO env Bool
doesAppConfigExist = do
  Paths
paths <- Getting Paths env Paths -> RIO env Paths
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Paths env Paths
forall env. HasPaths env => Lens' env Paths
pathsL
  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo "Verifying that there's no existing Headroom configuration..."
  FilePath -> RIO env Bool
forall (m :: * -> *). MonadIO m => FilePath -> m Bool
doesFileExist (FilePath -> RIO env Bool) -> FilePath -> RIO env Bool
forall a b. (a -> b) -> a -> b
$ Paths -> FilePath
pCurrentDir Paths
paths FilePath -> FilePath -> FilePath
</> Paths -> FilePath
pConfigFile Paths
paths

-- | Creates directory for template files.
makeTemplatesDir :: (HasLogFunc env, HasPaths env) => RIO env ()
makeTemplatesDir :: RIO env ()
makeTemplatesDir = do
  Paths
paths <- Getting Paths env Paths -> RIO env Paths
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Paths env Paths
forall env. HasPaths env => Lens' env Paths
pathsL
  let templatesDir :: FilePath
templatesDir = Paths -> FilePath
pCurrentDir Paths
paths FilePath -> FilePath -> FilePath
</> Paths -> FilePath
pTemplatesDir Paths
paths
  Utf8Builder -> RIO env ()
forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logInfo (Utf8Builder -> RIO env ()) -> Utf8Builder -> RIO env ()
forall a b. (a -> b) -> a -> b
$ "Creating directory for templates in " Utf8Builder -> Utf8Builder -> Utf8Builder
forall a. Semigroup a => a -> a -> a
<> FilePath -> Utf8Builder
forall a. IsString a => FilePath -> a
fromString FilePath
templatesDir
  FilePath -> RIO env ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
createDirectory FilePath
templatesDir