{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE GADTs #-}
module Shh.Internal where
import Prelude hiding (lines, unlines)
import Control.Concurrent.Async
import Control.Concurrent.MVar
import Control.DeepSeq (force,NFData)
import Control.Exception as C
import Control.Monad
import Control.Monad.IO.Class
import qualified Data.ByteString as ByteString
import Data.ByteString.Lazy (ByteString, hGetContents, toStrict)
import qualified Data.ByteString.Lazy as BS
import Data.ByteString.Lazy.Builder.ASCII
import qualified Data.ByteString.Lazy.Char8 as BC8
import qualified Data.ByteString.Lazy.Search as Search
import Data.ByteString.Lazy.UTF8 (fromString, toString)
import Data.Char (isLower, isSpace, isAlphaNum, ord)
import Data.List (intercalate)
import qualified Data.List.Split as Split
import qualified Data.Map as Map
import Data.Maybe (isJust)
import Data.Typeable
import GHC.IO.BufferedIO
import GHC.IO.Device as IODevice hiding (read)
import GHC.IO.Encoding
import GHC.IO.Exception (IOErrorType(ResourceVanished))
import GHC.IO.Handle hiding (hGetContents)
import GHC.IO.Handle.Internals
import GHC.IO.Handle.Types
import GHC.IO.Handle.Types (Handle(..))
import GHC.Stack
import Language.Haskell.TH
import qualified System.Directory as Dir
import System.Environment (getEnv, setEnv)
import System.Exit (ExitCode(..))
import System.FilePath (takeFileName, (</>))
import System.IO (IOMode(..), withFile, withBinaryFile, stderr, stdout, stdin)
import System.IO.Error
import System.Posix.Signals
import System.Process
import Text.Printf
initInteractive :: IO ()
initInteractive = do
hSetBuffering stdin LineBuffering
data Failure = Failure
{ failureProg :: ByteString
, failureArgs :: [ByteString]
, failureStack :: CallStack
, failureCode :: Int
, failureStdErr :: Maybe ByteString
}
instance Show Failure where
show f = concat $
[ "Command `"
]
++ [intercalate " " (toString (failureProg f) : map show (failureArgs f))]
++
[ "` failed [exit "
, show (failureCode f)
, "] at "
, prettyCallStack (failureStack f)
]
++ flip (maybe []) (failureStdErr f) (\s ->
["\n-- stderr --\n" ++ toString s])
instance Exception Failure
class Shell f where
runProc :: HasCallStack => Proc a -> f a
buildProc :: Shell f => (Handle -> Handle -> Handle -> IO a) -> f a
buildProc = runProc . Proc
pipe :: Shell f => Proc a -> Proc b -> f (a, b)
pipe (Proc a) (Proc b) = buildProc $ \i o e ->
withPipe $ \r w -> do
let
a' = a i w e `finally` (hClose w)
b' = b r o e `finally` (hClose r)
concurrently a' b'
pipeErr :: Shell f => Proc a -> Proc b -> f (a, b)
pipeErr (Proc a) (Proc b) = buildProc $ \i o e -> do
withPipe $ \r w -> do
let
a' = a i o w `finally` (hClose w)
b' = b r o e `finally` (hClose r)
concurrently a' b'
(|>) :: Shell f => Proc a -> Proc b -> f b
a |> b = runProc $ do
v <- fmap snd (a `pipe` b)
pure $! v
infixl 1 |>
(|!>) :: Shell f => Proc a -> Proc b -> f b
a |!> b = runProc $ do
v <- fmap snd (a `pipeErr` b)
pure $! v
infixl 1 |!>
(&>) :: Shell f => Proc a -> Stream -> f a
p &> StdOut = runProc p
(Proc f) &> StdErr = buildProc $ \i _ e -> f i e e
(Proc f) &> (Truncate path) = buildProc $ \i _ e ->
withBinaryFile (toString path) WriteMode $ \h -> f i h e
(Proc f) &> (Append path) = buildProc $ \i _ e ->
withBinaryFile (toString path) AppendMode $ \h -> f i h e
infixl 9 &>
(&!>) :: Shell f => Proc a -> Stream -> f a
p &!> StdErr = runProc $ p
(Proc f) &!> StdOut = buildProc $ \i o _ -> f i o o
(Proc f) &!> (Truncate path) = buildProc $ \i o _ ->
withBinaryFile (toString path) WriteMode $ \h -> f i o h
(Proc f) &!> (Append path) = buildProc $ \i o _ ->
withBinaryFile (toString path) AppendMode $ \h -> f i o h
infixl 9 &!>
nativeProc :: (Shell f, NFData a) => (Handle -> Handle -> Handle -> IO a) -> f a
nativeProc f = runProc $ Proc $ \i o e -> handle handler $ do
withDuplicates i o e $ \i' o' e' -> do
(f i' o' e' >>= C.evaluate . force)
`finally` (hClose i')
`finally` (hClose o')
`finally` (hClose e')
where
handler :: IOError -> IO a
handler e
| ioeGetErrorType e == ResourceVanished = pure (throw e)
| otherwise = throwIO e
(<|) :: Shell f => Proc a -> Proc b -> f a
(<|) = flip (|>)
infixr 1 <|
withPipe :: (Handle -> Handle -> IO a) -> IO a
withPipe k =
bracket
createPipe
(\(r,w) -> hClose r `finally` hClose w)
(\(r,w) -> k r w)
writeOutput :: (ExecArg a, Shell io) => a -> io ()
writeOutput s = nativeProc $ \_ o _ -> do
mapM_ (BS.hPutStr o) (asArg s)
writeError :: (ExecArg a, Shell io) => a -> io ()
writeError s = nativeProc $ \_ _ e -> do
mapM_ (BS.hPutStr e) (asArg s)
readInput :: (NFData a, Shell io) => (ByteString -> IO a) -> io a
readInput f = nativeProc $ \i _ _ -> do
hGetContents i >>= f
unlines :: [ByteString] -> ByteString
unlines = toLazyByteString . mconcat . map (\l -> lazyByteString l <> char7 '\n')
readInputEndBy :: (NFData a, Shell io) => ByteString -> ([ByteString] -> IO a) -> io a
readInputEndBy s f = readInput (f . endBy s)
readInputEndBy0 :: (NFData a, Shell io) => ([ByteString] -> IO a) -> io a
readInputEndBy0 = readInputEndBy "\0"
readInputLines :: (NFData a, Shell io) => ([ByteString] -> IO a) -> io a
readInputLines = readInputEndBy "\n"
pureProc :: Shell io => (ByteString -> ByteString) -> io ()
pureProc f = nativeProc $ \i o _ -> do
s <- hGetContents i
BS.hPutStr o (f s)
prefixLines :: Shell io => ByteString -> io ()
prefixLines s = pureProc $ \inp -> toLazyByteString $
mconcat $ map (\l -> lazyByteString s <> lazyByteString l <> char7 '\n') (BC8.lines inp)
writeProc :: Shell io => Proc a -> ByteString -> io a
writeProc p s = writeOutput s |> p
withRead :: (Shell f, NFData b) => Proc a -> (ByteString -> IO b) -> f b
withRead p f = p |> readInput f
data Stream = StdOut | StdErr | Truncate ByteString | Append ByteString
devNull :: Stream
devNull = Truncate "/dev/null"
newtype Proc a = Proc (Handle -> Handle -> Handle -> IO a)
deriving Functor
instance MonadIO Proc where
liftIO a = buildProc $ \_ _ _ -> a
instance Semigroup (Proc a) where
(<>) = (|>)
instance (a ~ ()) => Monoid (Proc a) where
mempty = buildProc $ \_ _ _ -> pure ()
instance Applicative Proc where
pure a = buildProc $ \_ _ _ -> do
pure a
f <*> a = do
f' <- f
a' <- a
pure (f' a')
instance Monad Proc where
(Proc a) >>= f = buildProc $ \i o e -> do
ar <- a i o e
let
Proc f' = f ar
f' i o e
instance Shell IO where
runProc = runProc' stdin stdout stderr
instance Shell Proc where
runProc = id
runProc' :: Handle -> Handle -> Handle -> Proc a -> IO a
runProc' i o e (Proc f) = do
hFlush stdout
hFlush stderr
r <- f i o e
pure $! r
mkProc' :: HasCallStack => Bool -> ByteString -> [ByteString] -> Proc ()
mkProc' delegate cmd args = Proc $ \i o e -> do
let
cmd' = toString cmd
args' = toString <$> args
bracket
(createProcess_ cmd' (proc cmd' args')
{ std_in = UseHandle i
, std_out = UseHandle o
, std_err = UseHandle e
, close_fds = True
, delegate_ctlc = delegate
}
)
(\(_,_,_,ph) -> terminateProcess ph >> waitForProcess ph)
$ \(_,_,_,ph) -> waitProc cmd args ph `onException` (terminateProcess ph >> waitForProcess ph)
mkProc :: HasCallStack => ByteString -> [ByteString] -> Proc ()
mkProc = mkProc' False
capture :: Shell io => io ByteString
capture = readInput pure
captureTrim :: Shell io => io ByteString
captureTrim = readInput (pure . trim)
captureEndBy :: Shell io => ByteString -> io [ByteString]
captureEndBy s = readInput (pure . endBy s)
captureEndBy0 :: Shell io => io [ByteString]
captureEndBy0 = captureEndBy "\0"
captureLines :: Shell io => io [ByteString]
captureLines = captureEndBy "\n"
captureWords :: Shell io => io [ByteString]
captureWords = readInput (pure . BC8.words)
captureRead :: (Shell io, Read a, NFData a) => io a
captureRead = readInput (pure . read . toString)
apply :: (ExecArg a, Shell io) => Proc v -> a -> io ByteString
apply p b = writeOutput b |> p |> capture
(>>>) :: Shell io => ByteString -> Proc a -> io a
(>>>) = flip writeProc
(<<<) :: Shell io => Proc a -> ByteString -> io a
(<<<) = writeProc
waitProc :: HasCallStack => ByteString -> [ByteString] -> ProcessHandle -> IO ()
waitProc cmd arg ph = waitForProcess ph >>= \case
ExitFailure c
| fromIntegral c == negate sigPIPE -> pure ()
| otherwise -> throwIO $ Failure cmd arg callStack c Nothing
ExitSuccess -> pure ()
dropWhileEnd :: (Char -> Bool) -> ByteString -> ByteString
dropWhileEnd p b = case BC8.unsnoc b of
Just (i, l) -> if p l then dropWhileEnd p i else b
Nothing -> b
trim :: ByteString -> ByteString
trim = dropWhileEnd isSpace . BC8.dropWhile isSpace
tryFailure :: Shell m => Proc a -> m (Either Failure a)
tryFailure (Proc f) = buildProc $ \i o e -> try $ f i o e
tryFailureJust :: Shell m => (Failure -> Maybe b) -> Proc a -> m (Either b a)
tryFailureJust pr (Proc f) = buildProc $ \i o e -> tryJust pr (f i o e)
catchFailure :: Shell m => Proc a -> (Failure -> Proc a) -> m a
catchFailure (Proc f) pr = buildProc $ \i o e -> catch (f i o e) (runProc . pr)
catchFailureJust :: Shell m => (Failure -> Maybe b) -> Proc a -> (b -> Proc a) -> m a
catchFailureJust pr (Proc f) h = buildProc $ \i o e -> catchJust pr (f i o e) (runProc . h)
translateCode' :: Shell m => (Int -> Maybe b) -> Proc a -> m (Either b a)
translateCode' f p = tryFailureJust (f . failureCode) p
translateCode :: Shell m => (Int -> Maybe a) -> Proc a -> m a
translateCode f p = catchFailureJust (f . failureCode) p pure
failWithStdErr :: Shell io => Proc a -> io a
failWithStdErr p = runProc $ do
r <- tryFailure p `pipeErr` readInputP (\i -> do
writeError i
pure i
)
case r of
(Right a, _) -> pure a
(Left f, err) -> liftIO $ throwIO $ f {failureStdErr = Just err}
ignoreFailure :: (Functor m, Shell m) => Proc a -> m ()
ignoreFailure = void . tryFailure
exitCode :: (Functor m, Shell m) => Proc a -> m Int
exitCode = fmap getCode . tryFailure
where
getCode (Right _) = 0
getCode (Left f) = failureCode f
ignoreCode :: (Monad m, Shell m) => Int -> Proc a -> m ()
ignoreCode code p = catchFailureJust pr (void p) pure
where
pr f
| failureCode f == code = Just ()
| otherwise = Nothing
class ExecArg a where
asArg :: a -> [ByteString]
default asArg :: Show a => a -> [ByteString]
asArg a = [fromString $ show a]
asArgFromList :: [a] -> [ByteString]
default asArgFromList :: Show a => [a] -> [ByteString]
asArgFromList = concatMap asArg
instance ExecArg Char where
asArg s = [fromString [s]]
asArgFromList s = [fromString s]
instance ExecArg a => ExecArg [a] where
asArg = asArgFromList
asArgFromList = concatMap asArg
instance ExecArg ByteString where
asArg s = [s]
instance ExecArg ByteString.ByteString where
asArg s = [BS.fromStrict s]
instance ExecArg Int
instance ExecArg Integer
instance ExecArg Word
class Command a where
toArgs :: HasCallStack => [ByteString] -> a
instance (a ~ ()) => Command (Proc a) where
toArgs (cmd:args) = mkProc cmd args
toArgs _ = error "The impossible happened. How did you construct this?"
instance (ExecArg b, Command a) => Command (b -> a) where
toArgs f i = toArgs $ f ++ asArg i
instance (a ~ ()) => Command (IO a) where
toArgs = runProc . toArgs
instance Command [ByteString] where
toArgs = id
instance Command [ByteString.ByteString] where
toArgs = map toStrict
type Cmd = HasCallStack => forall a. (Command a) => a
displayCommand :: Cmd -> [ByteString]
displayCommand = toArgs
pathBins :: IO [FilePath]
pathBins = map takeFileName <$> pathBinsAbs
pathBinsAbs :: IO [FilePath]
pathBinsAbs = do
pathsVar <- Split.splitOn ":" <$> getEnv "PATH"
paths <- filterM Dir.doesDirectoryExist pathsVar
findBinsIn paths
findBinsIn :: [FilePath] -> IO [FilePath]
findBinsIn paths = do
ps <- ordNubOn takeFileName . concat <$> mapM (\d -> fmap (\x -> d++('/':x)) <$> Dir.getDirectoryContents d) paths
filterM (tryBool . fmap Dir.executable . Dir.getPermissions) ps
where
ordNubOn :: Ord b => (a -> b) -> [a] -> [a]
ordNubOn f as = map snd . Map.toList . Map.fromListWith const $ zip (map f as) as
tryBool :: IO Bool -> IO Bool
tryBool a = try a >>= \case
Left (SomeException _) -> pure False
Right r -> pure r
exe :: (Command a, ExecArg str, HasCallStack) => str -> a
exe s = withFrozenCallStack $ toArgs (asArg s)
loadExe :: ExecReference -> String -> Q [Dec]
loadExe ref s = loadExeAs ref s s
data ExecReference
= Absolute
| SearchPath
rawExe :: String -> String -> Q [Dec]
rawExe fnName executable = do
let
name = mkName $ fnName
impl = valD (varP name) (normalB [|
withFrozenCallStack $ exe executable
|]) []
typ = SigD name (ConT ''Cmd)
i <- impl
return $ [typ,i]
loadExeAs :: ExecReference -> String -> String -> Q [Dec]
loadExeAs ref fnName executable = do
runIO (Dir.findExecutable executable) >>= \case
Nothing -> error $ "Attempted to load '" ++ executable ++ "', but it is not executable"
Just absExe ->
rawExe fnName (case ref of { Absolute -> absExe; SearchPath -> executable })
encodeIdentifier :: String -> String
encodeIdentifier ident =
let
fixBody :: String -> String
fixBody (c:cs)
| isAlphaNum c = c : fixBody cs
| c == '-' = '_' : fixBody cs
| c == '_' = '\'' : '_' : fixBody cs
| c == '.' = '\'' : '\'' : fixBody cs
| otherwise = printf "'%x'%s" (ord c) (fixBody cs)
fixBody [] = []
fixStart :: String -> String
fixStart s@(c : _)
| isLower c = s
| otherwise = '_' : s
fixStart [] = []
i = fixStart $ fixBody $ takeFileName ident
reserved = [ "import", "if", "else", "then", "do", "in", "let", "type"
, "as", "case", "of", "class", "data", "default", "deriving"
, "instance", "forall", "foreign", "hiding", "infix", "infixl"
, "infixr", "mdo", "module", "newtype", "proc", "qualified"
, "rec", "where", "cd"]
in if i `elem` reserved then i ++ "_" else i
loadEnv :: ExecReference -> Q [Dec]
loadEnv ref = loadAnnotatedEnv ref encodeIdentifier
checkExecutable :: FilePath -> IO Bool
checkExecutable = fmap isJust . Dir.findExecutable
load :: ExecReference -> [FilePath] -> Q [Dec]
load ref = loadAnnotated ref encodeIdentifier
loadAnnotated :: ExecReference -> (String -> String) -> [FilePath] -> Q [Dec]
loadAnnotated ref f bins = do
let pairs = zip (map f bins) bins
ds <- fmap join $ mapM (uncurry (loadExeAs ref)) pairs
d <- valD (varP (mkName "missingExecutables")) (normalB [|
filterM (fmap not . checkExecutable) bins
|]) []
pure (d:ds)
loadAnnotatedEnv :: ExecReference -> (String -> String) -> Q [Dec]
loadAnnotatedEnv ref f = do
bins <- runIO $ case ref of
Absolute -> pathBinsAbs
SearchPath -> pathBins
i <- forM bins $ \bin -> do
rawExe (f $ takeFileName bin) bin
pure (concat i)
endBy :: ByteString -> ByteString -> [ByteString]
endBy s str =
let splits = Search.split (toStrict s) str
in dropLastNull splits
where
dropLastNull :: [ByteString] -> [ByteString]
dropLastNull [] = []
dropLastNull [""] = []
dropLastNull (a : as) = a : dropLastNull as
loadFromDirs :: [FilePath] -> Q [Dec]
loadFromDirs ps = loadAnnotatedFromDirs ps encodeIdentifier
loadFromBins :: [FilePath] -> Q [Dec]
loadFromBins = loadFromDirs . fmap (</> "bin")
loadAnnotatedFromDirs :: [FilePath] -> (String -> String) -> Q [Dec]
loadAnnotatedFromDirs ps f = do
bins <- runIO $ findBinsIn ps
i <- forM bins $ \bin -> do
rawExe (f $ takeFileName bin) bin
pure (concat i)
endBy0 :: ByteString -> [ByteString]
endBy0 = endBy "\0"
cd' :: FilePath -> IO ()
cd' p = do
Dir.setCurrentDirectory p
a <- Dir.getCurrentDirectory
setEnv "PWD" a
class Cd a where
cd :: a
instance (io ~ IO ()) => Cd io where
cd = getEnv "HOME" >>= cd'
instance {-# OVERLAPS #-} (io ~ IO (), path ~ FilePath) => Cd (path -> io) where
cd = cd'
xargs1 :: (NFData a, Monoid a) => ByteString -> (ByteString -> Proc a) -> Proc a
xargs1 n f = readInputEndByP n (fmap mconcat . mapM f)
readInputP :: (NFData a, Shell io) => (ByteString -> Proc a) -> io a
readInputP f = nativeProc $ \i o e -> do
s <- hGetContents i
withNullInput $ \i' ->
liftIO $ runProc' i' o e (f s)
readInputEndByP :: (NFData a, Shell io) => ByteString -> ([ByteString] -> Proc a) -> io a
readInputEndByP s f = readInputP (f . endBy s)
readInputEndBy0P :: (NFData a, Shell io) => ([ByteString] -> Proc a) -> io a
readInputEndBy0P = readInputEndByP "\0"
readInputLinesP :: (NFData a, Shell io) => ([ByteString] -> Proc a) -> io a
readInputLinesP = readInputEndByP "\n"
withNullInput :: (Handle -> IO a) -> IO a
withNullInput = withFile "/dev/null" ReadMode
withDuplicate :: Handle -> (Handle -> IO a) -> IO a
withDuplicate h f = bracket (hDup h) hClose f
withDuplicates :: Handle -> Handle -> Handle -> (Handle -> Handle -> Handle -> IO a) -> IO a
withDuplicates a b c f =
withDuplicate a $ \a' -> withDuplicate b $ \b' -> withDuplicate c $ \c' -> f a' b' c'
withDuplicateNullInput :: Handle -> Handle -> (Handle -> Handle -> Handle -> IO a) -> IO a
withDuplicateNullInput a b f = do
withNullInput $ \i -> do
withDuplicate a $ \a' -> withDuplicate b $ \b' -> f i a' b'
hDup :: Handle -> IO Handle
hDup h@(FileHandle path m) = do
withHandle_' "hDup" h m $ \h_ ->
dupHandleShh path h Nothing h_ (Just handleFinalizer)
hDup h@(DuplexHandle path r w) = do
(FileHandle _ write_m) <-
withHandle_' "hDup" h w $ \h_ ->
dupHandleShh path h Nothing h_ (Just handleFinalizer)
(FileHandle _ read_m) <-
withHandle_' "hDup" h r $ \h_ ->
dupHandleShh path h (Just write_m) h_ Nothing
return (DuplexHandle path read_m write_m)
dupHandleShh
:: FilePath
-> Handle
-> Maybe (MVar Handle__)
-> Handle__
-> Maybe HandleFinalizer
-> IO Handle
dupHandleShh filepath h other_side h_@Handle__{..} mb_finalizer = do
case other_side of
Nothing -> do
new_dev <- IODevice.dup haDevice
dupHandleShh_ new_dev filepath other_side h_ mb_finalizer
Just r ->
withHandle_' "dupHandleShh" h r $ \Handle__{haDevice=dev} -> do
dupHandleShh_ dev filepath other_side h_ mb_finalizer
dupHandleShh_
:: (IODevice dev, BufferedIO dev, Typeable dev) => dev
-> FilePath
-> Maybe (MVar Handle__)
-> Handle__
-> Maybe HandleFinalizer
-> IO Handle
dupHandleShh_ new_dev filepath other_side Handle__{..} mb_finalizer = do
mb_codec <- if isJust haEncoder then fmap Just getLocaleEncoding else return Nothing
mkHandle new_dev filepath haType True mb_codec
NewlineMode { inputNL = haInputNL, outputNL = haOutputNL }
mb_finalizer other_side