Internal.hs

-- |
-- Module      :  System.Hapistrano.Commands
-- Copyright   :  © 2015-Present Stack Builders
-- License     :  MIT
--
-- Stability   :  experimental
-- Portability :  portable
--
-- Collection of type safe shell commands that can be fed into
-- 'System.Hapistrano.Core.runCommand'.
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies        #-}
{-# LANGUAGE CPP                 #-}

module System.Hapistrano.Commands.Internal where

import           Control.Monad.IO.Class
import           Data.Char               (isSpace)
#if MIN_VERSION_base(4,15,0)
import           Data.Kind               (Type)
#endif
import           Data.List               (dropWhileEnd)
import           Data.Maybe              (catMaybes, fromJust, mapMaybe)
import           Data.Proxy
import           Numeric.Natural
import           Path

import           System.Hapistrano.Types (TargetSystem (..))

----------------------------------------------------------------------------
-- Commands
-- | Class for data types that represent shell commands in typed way.
class Command a where
  -- | Type of result.
#if MIN_VERSION_base(4,15,0)
  type Result a :: Type
#else
  type Result a :: *
#endif
  -- | How to render the command before feeding it into shell (possibly via
  -- SSH).
  renderCommand :: a -> String
  -- | How to parse the result from stdout.
  parseResult :: Proxy a -> String -> Result a

-- | Unix @whoami@.
data Whoami =
  Whoami
  deriving (Show, Eq, Ord)

instance Command Whoami where
  type Result Whoami = String
  renderCommand Whoami = "whoami"
  parseResult Proxy = trim

-- | Specify directory in which to perform another command.
data Cd cmd =
  Cd (Path Abs Dir) cmd

instance Command cmd => Command (Cd cmd) where
  type Result (Cd cmd) = Result cmd
  renderCommand (Cd path cmd) =
    "(cd " ++ quoteCmd (fromAbsDir path) ++ " && " ++ renderCommand cmd ++ ")"
  parseResult Proxy = parseResult (Proxy :: Proxy cmd)

-- | Create a directory. Does not fail if the directory already exists.
newtype MkDir =
  MkDir (Path Abs Dir)

instance Command MkDir where
  type Result MkDir = ()
  renderCommand (MkDir path) =
    formatCmd "mkdir" [Just "-pv", Just (fromAbsDir path)]
  parseResult Proxy _ = ()

-- | Delete file or directory.
data Rm where
  Rm :: Path Abs t -> Rm

instance Command Rm where
  type Result Rm = ()
  renderCommand (Rm path) = formatCmd "rm" [Just "-rf", Just (toFilePath path)]
  parseResult Proxy _ = ()

-- | Move or rename files or directories.
data Mv t =
  Mv TargetSystem (Path Abs t) (Path Abs t)

instance Command (Mv File) where
  type Result (Mv File) = ()
  renderCommand (Mv ts old new) =
    formatCmd "mv" [Just flags, Just (fromAbsFile old), Just (fromAbsFile new)]
    where
      flags =
        if isLinux ts
          then "-fvT"
          else "-fv"
  parseResult Proxy _ = ()

instance Command (Mv Dir) where
  type Result (Mv Dir) = ()
  renderCommand (Mv _ old new) =
    formatCmd "mv" [Just "-fv", Just (fromAbsDir old), Just (fromAbsDir new)]
  parseResult Proxy _ = ()

-- | Create symlinks.
data Ln where
  Ln :: TargetSystem -> Path Abs t -> Path Abs File -> Ln

instance Command Ln where
  type Result Ln = ()
  renderCommand (Ln ts target linkName) =
    formatCmd
      "ln"
      [Just flags, Just (toFilePath target), Just (fromAbsFile linkName)]
    where
      flags =
        if isLinux ts
          then "-svT"
          else "-sv"
  parseResult Proxy _ = ()

-- | Read link.
data Readlink t =
  Readlink TargetSystem (Path Abs File)

instance Command (Readlink File) where
  type Result (Readlink File) = Path Abs File
  renderCommand (Readlink ts path) =
    formatCmd "readlink" [flags, Just (toFilePath path)]
    where
      flags =
        if isLinux ts
          then Just "-f"
          else Nothing
  parseResult Proxy = fromJust . parseAbsFile . trim

instance Command (Readlink Dir) where
  type Result (Readlink Dir) = Path Abs Dir
  renderCommand (Readlink ts path) =
    formatCmd "readlink" [flags, Just (toFilePath path)]
    where
      flags =
        if isLinux ts
          then Just "-f"
          else Nothing
  parseResult Proxy = fromJust . parseAbsDir . trim

-- | @ls@, so far used only to check existence of directories, so it's not
-- very functional right now.
newtype Ls =
  Ls (Path Abs Dir)

instance Command Ls where
  type Result Ls = ()
  renderCommand (Ls path) = formatCmd "ls" [Just (fromAbsDir path)]
  parseResult Proxy _ = ()

-- | Find (a very limited version).
data Find t =
  Find Natural (Path Abs Dir)

instance Command (Find Dir) where
  type Result (Find Dir) = [Path Abs Dir]
  renderCommand (Find maxDepth dir) =
    formatCmd
      "find"
      [ Just (fromAbsDir dir)
      , Just "-maxdepth"
      , Just (show maxDepth)
      , Just "-type"
      , Just "d"
      ]
  parseResult Proxy = mapMaybe (parseAbsDir . trim) . lines

instance Command (Find File) where
  type Result (Find File) = [Path Abs File]
  renderCommand (Find maxDepth dir) =
    formatCmd
      "find"
      [ Just (fromAbsDir dir)
      , Just "-maxdepth"
      , Just (show maxDepth)
      , Just "-type"
      , Just "f"
      ]
  parseResult Proxy = mapMaybe (parseAbsFile . trim) . lines

-- | @touch@.
newtype Touch =
  Touch (Path Abs File)

instance Command Touch where
  type Result Touch = ()
  renderCommand (Touch path) = formatCmd "touch" [Just (fromAbsFile path)]
  parseResult Proxy _ = ()

-- | Command that checks for the existance of a particular
-- file in the host.

newtype CheckExists =
  CheckExists
  (Path Abs File) -- ^ The absolute path to the file you want to check for existence

instance Command CheckExists where
  type Result CheckExists = Bool
  renderCommand (CheckExists path) = 
    "([ -r " <> fromAbsFile path <> " ] && echo True) || echo False"
  parseResult Proxy = read

-- | Command used to read the contents of a particular
-- file in the host.

newtype Cat =
  Cat
  (Path Abs File) -- ^ The absolute path to the file you want to read

instance Command Cat where
  type Result Cat = String
  renderCommand (Cat path) = formatCmd "cat" [Just (fromAbsFile path)]
  parseResult Proxy = id 

-- | Basic command that writes to a file some contents.
-- It uses the @file > contents@ shell syntax and the @contents@ is
-- represented as a 'String', so it shouldn't be used for
-- bigger writing operations. Currently used to write @fail@ or @success@
-- to the @.hapistrano_deploy_state@ file.
data BasicWrite =
  BasicWrite 
  (Path Abs File) -- ^ The absolute path to the file to which you want to write
  String -- ^ The contents that will be written to the file

instance Command BasicWrite where
  type Result BasicWrite = ()
  renderCommand (BasicWrite path contents) =
     "echo \"" <> contents <> "\"" <> " > " <> fromAbsFile path
  parseResult Proxy _ = ()

-- | Git checkout.
newtype GitCheckout =
  GitCheckout String

instance Command GitCheckout where
  type Result GitCheckout = ()
  renderCommand (GitCheckout revision) =
    formatCmd "git" [Just "checkout", Just revision]
  parseResult Proxy _ = ()

-- | Git clone.
data GitClone =
  GitClone Bool (Either String (Path Abs Dir)) (Path Abs Dir)

instance Command GitClone where
  type Result GitClone = ()
  renderCommand (GitClone bare src dest) =
    formatCmd
      "git"
      [ Just "clone"
      , if bare
          then Just "--bare"
          else Nothing
      , Just
          (case src of
             Left repoUrl  -> repoUrl
             Right srcPath -> fromAbsDir srcPath)
      , Just (fromAbsDir dest)
      ]
  parseResult Proxy _ = ()

-- | Git fetch (simplified).
newtype GitFetch =
  GitFetch String

instance Command GitFetch where
  type Result GitFetch = ()
  renderCommand (GitFetch remote) =
    formatCmd
      "git"
      [Just "fetch", Just remote, Just "+refs/heads/\\*:refs/heads/\\*"]
  parseResult Proxy _ = ()

-- | Git reset.
newtype GitReset =
  GitReset String

instance Command GitReset where
  type Result GitReset = ()
  renderCommand (GitReset revision) =
    formatCmd "git" [Just "reset", Just revision]
  parseResult Proxy _ = ()

-- | Weakly-typed generic command, avoid using it directly.
newtype GenericCommand =
  GenericCommand String
  deriving (Show, Eq, Ord)

instance Command GenericCommand where
  type Result GenericCommand = ()
  renderCommand (GenericCommand cmd) = cmd
  parseResult Proxy _ = ()

-- | Smart constructor that allows to create 'GenericCommand's. Just a
-- little bit more safety.
mkGenericCommand :: String -> Maybe GenericCommand
mkGenericCommand str =
  if '\n' `elem` str' || null str'
    then Nothing
    else Just (GenericCommand str')
  where
    str' = trim (takeWhile (/= '#') str)

-- | Get the raw command back from 'GenericCommand'.
unGenericCommand :: GenericCommand -> String
unGenericCommand (GenericCommand x) = x

-- | Read commands from a file.
readScript :: MonadIO m => Path Abs File -> m [GenericCommand]
readScript path =
  liftIO $ mapMaybe mkGenericCommand . lines <$> readFile (fromAbsFile path)

----------------------------------------------------------------------------
-- Helpers
-- | Format a command.
formatCmd :: String -> [Maybe String] -> String
formatCmd cmd args = unwords (quoteCmd <$> (cmd : catMaybes args))

-- | Simple-minded quoter.
quoteCmd :: String -> String
quoteCmd str =
  if any isSpace str
    then "\"" ++ str ++ "\""
    else str

-- | Trim whitespace from beginning and end.
trim :: String -> String
trim = dropWhileEnd isSpace . dropWhile isSpace

-- | Determines whether or not the target system is a Linux machine.
isLinux :: TargetSystem -> Bool
isLinux = (== GNULinux)