Get.hs

{-|
Functions for marshalling Project and File Templates into a program.
-}
{-# LANGUAGE BangPatterns      #-}
{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE OverloadedStrings #-}
module ProjectForge.Get (
  -- * Get Templates
  -- $getTemplates
    getProjectTemplateFromDir
  , getProjectTemplateFromGit
  , getFileTemplateFromFile
) where

import           Blammo.Logging.Simple
import           Control.Exception
import           Control.Monad
import           Control.Monad.IO.Class
import qualified Data.ByteString              as BL
import           Data.Maybe                   (fromMaybe)
import           Data.Text
import           Data.Text.Encoding
import           GHC.Generics
import           ProjectForge.Compile
import           ProjectForge.Get.Git
import           ProjectForge.ProjectTemplate
import           System.Directory
import           System.FilePath
import           System.IO.Temp
import           System.Process.Typed

{- $getTemplates

Utilities for converting a directory into a @'ProjectTemplate'@.

-}

{-|
Ways in which getting a project template may go badly.
-}
data GetProjectTemplateError =
    NotADirectory
  | FileNotFound
  | NotAMustacheFile
  | DecodeError
  deriving (Show, Generic)

instance Exception GetProjectTemplateError

{-|
Converts a list of @FilePath@ and @ByteString@ pairs to a @'ProjectTemplate'@.

The @ByteString@ are decoded into @'Data.Text.Text'@ by
@'Data.Text.Encoding.decodeUtf8'@.
If decoding results in a @Data.Text.Encoding.Error.UnicodeException@
for any value,
then this is thrown as an exception.
-}
directoryListToTemplate :: (MonadIO m) =>
    [(FilePath, BL.ByteString)]
    -- | list of (@FilePath@, @ByteString@) pairs
    -- corresponding to the contents of a template directory
  -> m ProjectTemplate
directoryListToTemplate x =
  compileProjectTemplate =<< traverse (traverse decodeToText) x

-- Internal utilitie for converting a bytestring to text.
decodeToText :: MonadIO m => BL.ByteString -> m Text
decodeToText x = case decodeUtf8' x of
  Left e  -> liftIO $ throwIO e
  Right v -> pure v

{-|
Convert a file to a @'FileTemplate'@.
A @GetProjectTemplateError@ exception is thrown if the input file
does not exist.

>>> runSimpleLoggingT $ getFileTemplateFromFile "foo.txt"
FileNotFound

-}
getFileTemplateFromFile :: (MonadLogger m, MonadIO m) =>
    FilePath -- ^ name of the file
  -> m FileTemplate
getFileTemplateFromFile f = do
  fileExists <- liftIO $ doesFileExist f
  if fileExists then do
    logDebug $ "Getting template from" :# [ "path" .= f ]
    contents <- decodeToText =<< liftIO (BL.readFile f)
    compileFileTemplate (f, contents)
  else do
    logError $ "File not found" :# [ "path" .= f ]
    liftIO $ throwIO FileNotFound


{-|
Convert a directory to a @'ProjectTemplate'@.
A @GetProjectTemplateError@ exception is thrown if the input directory
does not exist.

>>> runSimpleLoggingT $ getProjectTemplateFromDir "foo"
NotADirectory

-}
getProjectTemplateFromDir :: (MonadLogger m, MonadIO m) =>
    FilePath -- ^ name of the directory containing template files
  -> m ProjectTemplate
getProjectTemplateFromDir d = do
  dirExists <- liftIO $ doesDirectoryExist d
  if dirExists then do
    logDebug $ "Getting template from" :# [ "path" .= d ]
    listRecursiveDirectoryFiles d >>= directoryListToTemplate
  else do
    logError $ "Directory not found" :# [ "path" .= d ]
    liftIO $ throwIO NotADirectory

{-|
Convert a git repository to a @ProjectTemplate@.

This action creates a shallow clone of the repo in a temporary directory
before calling @'getProjectTemplateFromDir'@ on the temporary directory.
The temporary directory is removed when complete.

This function __requires that__
__[`git` be installed](https://git-scm.com/book/en/v2/Getting-Started-Installing-Git)__.
-}
getProjectTemplateFromGit :: (MonadLogger m, MonadIO m) =>
   -- | Optional parent directory in which to clone the repo in.
   --   Defaults to current directory.
      Maybe FilePath
   -- | The [Git URL](https://www.git-scm.com/docs/git-clone#_git_urls)
   --   of the template directory.
   -> GitURL
   -- | Optional name of git branch.
   --   If @Nothing@, uses default git branch.
   -> Maybe Branch
   -> m ProjectTemplate
getProjectTemplateFromGit baseDir repository branch = do
  tmpDir <- liftIO $ createTempDirectory (fromMaybe "" baseDir) "dir"
  logDebug $ "Created temporary directory for cloning" :# [ "path" .= tmpDir ]

  let cloneArgs = MkGitCloneArgs {
      repository = repository
    , directory = tmpDir
    , branch = branch
    , depth = Just 1
  }

  logDebug $ "Beginning git clone into" :# [ "path" .= tmpDir ]
  liftIO $ runProcess_ (gitClone cloneArgs)

  logDebug $ "Removing .git directory" :# [ "path" .= tmpDir ]
  liftIO $ removeDirectoryRecursive (tmpDir </> ".git")

  logDebug "Getting Project template from cloned directory"
  !template <- getProjectTemplateFromDir tmpDir

  logDebug $ "Removing cloned directory" :# [ "path" .= tmpDir ]
  liftIO $ removeDirectoryRecursive tmpDir

  pure template

{-
The following are basically lifted from:
https://hackage.haskell.org/package/file-embed-lzma-0.0.1/docs/src/FileEmbedLzma.html#listRecursiveDirectoryFiles
-}

listRecursiveDirectoryFiles :: MonadIO m => FilePath -> m [(FilePath, BL.ByteString)]
listRecursiveDirectoryFiles = listDirectoryFilesF listRecursiveDirectoryFiles

listDirectoryFilesF :: MonadIO m =>
    (FilePath -> m [(FilePath, BL.ByteString)]) -- ^ what to do with a sub-directory
    -> FilePath -> m [(FilePath, BL.ByteString)]
listDirectoryFilesF go topdir = do
    names <- liftIO $ getDirectoryContents topdir
    let properNames = Prelude.filter (`notElem` [".", ".."]) names
    paths <- forM properNames $ \name -> do
        let path = topdir </> name
        isDirectory <- liftIO $ doesDirectoryExist path
        if isDirectory
        then go path
        else do
            contents <- liftIO $ BL.readFile path
            pure [(path, contents)]
    pure (Prelude.concat paths)