{-# LANGUAGE FlexibleContexts #-}
module Purebred.System.Process
( tryReadProcessStderr
, tryReadProcessStdout
, handleIOException
, handleExitCodeThrow
, handleExitCodeTempfileContents
, outputToText
, Purebred.System.Process.readProcess
, tmpfileResource
, draftFileResoure
, emptyResource
, toProcessConfigWithTempfile
, runEntityCommand
, createDraftFilePath
, createSentFilePath
, ProcessConfig
, proc
, shell
, setStdin
, byteStringInput
) where
import Data.Bifunctor (bimap)
import Data.Functor (($>))
import System.Exit (ExitCode(..))
import Control.Exception (IOException)
import Control.Monad.Catch (bracket, MonadMask)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Except (MonadError, throwError)
import Control.Lens (_2, over, set, view)
import Data.Semigroup ((<>))
import System.Process.Typed
import System.IO.Temp (emptyTempFile, emptySystemTempFile)
import System.FilePath ((</>))
import System.Directory (removeFile, createDirectoryIfMissing)
import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString as B
import Data.Char (isControl, isSpace)
import Data.Foldable (toList)
import Data.List (intercalate)
import Data.Time.Clock (getCurrentTime)
import Data.Time.Format (formatTime, defaultTimeLocale)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Error
import Types
import Purebred.System (tryIO, exceptionToError)
import Purebred.Types.IFC
handleExitCodeThrow ::
(MonadError Error m, MonadIO m)
=> (ExitCode, Tainted LB.ByteString)
-> a
-> m T.Text
handleExitCodeThrow (ExitFailure e, out) _ =
throwError $ ProcessError (show e <> ": " <> T.unpack (outputToText out))
handleExitCodeThrow (ExitSuccess, out) _ = pure (outputToText out)
handleExitCodeTempfileContents ::
(MonadError Error m, MonadIO m)
=> (ExitCode, Tainted LB.ByteString)
-> FilePath
-> m T.Text
handleExitCodeTempfileContents (ExitFailure e, out) _ =
throwError $ ProcessError (show e <> ": " <> T.unpack (outputToText out))
handleExitCodeTempfileContents (ExitSuccess, _) tempfile = tryIO $ T.readFile tempfile
outputToText :: Tainted LB.ByteString -> T.Text
outputToText = untaint (sanitiseText . decodeLenient . LB.toStrict)
handleIOException :: AppState -> IOException -> IO AppState
handleIOException s = pure . flip setError s . exceptionToError
setError :: Error -> AppState -> AppState
setError = set asError . Just
tryReadProcessStderr ::
(MonadError Error m, MonadIO m)
=> ProcessConfig stdoutIgnored stderr stdin
-> m (ExitCode, Tainted LB.ByteString)
tryReadProcessStderr pc = over _2 taint <$> tryIO (readProcessStderr pc)
tryReadProcessStdout ::
(MonadError Error m, MonadIO m)
=> ProcessConfig stdout stderrIgnored stdin
-> m (ExitCode, Tainted LB.ByteString)
tryReadProcessStdout pc = over _2 taint <$> tryIO (readProcessStdout pc)
readProcess
:: (MonadIO m)
=> ProcessConfig stdin stdoutIgnored stderrIgnored
-> m (ExitCode, Tainted LB.ByteString, Tainted LB.ByteString)
readProcess = (fmap . fmap) (bimap taint taint) System.Process.Typed.readProcess
runEntityCommand ::
(MonadMask m, MonadError Error m, MonadIO m)
=> EntityCommand m a
-> m T.Text
runEntityCommand cmd =
let acquire = view (ccResource . rsAcquire) cmd
update = view (ccResource . rsUpdate) cmd
free = view (ccResource . rsFree) cmd
run = view ccRunProcess cmd
afterExit = view ccAfterExit cmd
in bracket
(acquire >>= \tmpfile -> update tmpfile (view ccEntity cmd) $> tmpfile)
free
(\tmpfile ->
run (view ccProcessConfig cmd (view ccEntity cmd) tmpfile) >>=
flip afterExit tmpfile)
tmpfileResource ::
(MonadIO m, MonadError Error m)
=> TempfileOnExit
-> ResourceSpec m FilePath
tmpfileResource tmpOnExit =
let cleanUp KeepTempfile = mempty
cleanUp _ = removeFile
in ResourceSpec
(tryIO $ emptySystemTempFile "purebred")
(tryIO . cleanUp tmpOnExit)
(\fp -> tryIO . B.writeFile fp)
emptyResource :: (MonadIO m, MonadError Error m) => ResourceSpec m ()
emptyResource =
ResourceSpec (pure mempty) (\_ -> pure mempty) (\_ _ -> pure mempty)
draftFileResoure ::
(MonadIO m, MonadError Error m)
=> FilePath
-> ResourceSpec m FilePath
draftFileResoure maildir =
ResourceSpec
(createDraftFilePath maildir)
(tryIO . removeFile)
(\fp -> tryIO . B.writeFile fp)
toProcessConfigWithTempfile :: MakeProcess -> FilePath -> ProcessConfig () () ()
toProcessConfigWithTempfile (Shell cmd) fp = shell (toList cmd <> " " <> fp)
toProcessConfigWithTempfile (Process cmd args) fp = proc (toList cmd) (args <> [fp])
maildirMessageFileTemplate :: MonadIO m => m FilePath
maildirMessageFileTemplate = do
left <- liftIO $ formatTime defaultTimeLocale "%s" <$> getCurrentTime
middle <- liftIO $ formatTime defaultTimeLocale "%p" <$> getCurrentTime
right <- getHostname
pure $ intercalate "." [left, middle, right]
getHostname :: (MonadIO m) => m String
getHostname = do
(exitc, out, _) <- Purebred.System.Process.readProcess (proc "hostname" [])
case exitc of
ExitSuccess -> pure (decode out)
ExitFailure _ -> pure "localhost"
where
decode =
untaint
(T.unpack .
T.filter (\x -> not (isControl x || isSpace x)) .
sanitiseText . decodeLenient . LB.toStrict)
createDraftFilePath :: (MonadError Error m, MonadIO m) => FilePath -> m FilePath
createDraftFilePath maildir = touchMaildirFilePath (maildir </> "Drafts" </> "new")
createSentFilePath :: (MonadError Error m, MonadIO m) => FilePath -> m FilePath
createSentFilePath maildir = touchMaildirFilePath (maildir </> "Sent" </> "cur")
touchMaildirFilePath :: (MonadError Error m, MonadIO m) => FilePath -> m FilePath
touchMaildirFilePath maildir = tryIO $ do
createDirectoryIfMissing True maildir
maildirMessageFileTemplate >>= emptyTempFile maildir