{-# LANGUAGE FlexibleInstances #-}
{-# 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 Control.Concurrent.MVar
import Control.Concurrent.Async
import Control.DeepSeq (force,NFData)
import Control.Exception as C
import Control.Monad
import Control.Monad.IO.Class
import Data.Char (isLower, isSpace, isAlphaNum, isUpper, toLower, isNumber)
import Data.List (dropWhileEnd, intercalate)
import Data.List.Split (endBy, splitOn)
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
import GHC.IO.Handle.Internals
import GHC.IO.Handle.Types
import GHC.IO.Handle.Types (Handle(..))
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
import System.IO.Error
import System.Posix.Signals
import System.Process
initInteractive :: IO ()
initInteractive = do
hSetBuffering stdin LineBuffering
data Failure = Failure
{ failureProg :: String
, failureArgs :: [String]
, failureCode :: Int
} deriving (Eq, Ord)
instance Show Failure where
show f = concat $
[ "Command `"
]
++ [intercalate " " (failureProg f : map show (failureArgs f))]
++
[ "` failed [exit "
, show (failureCode f)
, "]"
]
instance Exception Failure
class PipeResult f where
(|>) :: Proc b -> Proc a -> f a
infixl 1 |>
(|!>) :: Proc b -> Proc a -> f a
infixl 1 |!>
(&>) :: Proc a -> Stream -> f a
infixl 9 &>
(&!>) :: Proc a -> Stream -> f a
infixl 9 &!>
nativeProc :: NFData a => (Handle -> Handle -> Handle -> IO a) -> f a
(<|) :: PipeResult f => Proc a -> Proc b -> f a
(<|) = flip (|>)
infixr 1 <|
instance PipeResult IO where
a |> b = runProc $ a |> b
a |!> b = runProc $ a |!> b
a &> s = runProc $ a &> s
a &!> s = runProc $ a &!> s
nativeProc f = runProc $ nativeProc f
withPipe :: (Handle -> Handle -> IO a) -> IO a
withPipe k =
bracket
createPipe
(\(r,w) -> hClose r `finally` hClose w)
(\(r,w) -> k r w)
instance PipeResult Proc where
(Proc a) |> (Proc b) = Proc $ \i o e pl pw ->
withPipe $ \r w -> do
let
a' = a i w e (pure ()) (hClose w)
b' = b r o e (pure ()) (hClose r)
(_, br) <- (pl >> concurrently a' b') `finally` pw
pure br
(Proc a) |!> (Proc b) = Proc $ \i o e pl pw -> do
withPipe $ \r w -> do
let
a' = a i o w (pure ()) (hClose w)
b' = b r o e (pure ()) (hClose r)
(_, br) <- (pl >> concurrently a' b') `finally` pw
pure br
p &> StdOut = p
(Proc f) &> StdErr = Proc $ \i _ e pl pw -> f i e e pl pw
(Proc f) &> (Truncate path) = Proc $ \i _ e pl pw ->
withBinaryFile path WriteMode $ \h -> f i h e pl pw
(Proc f) &> (Append path) = Proc $ \i _ e pl pw ->
withBinaryFile path AppendMode $ \h -> f i h e pl pw
p &!> StdErr = p
(Proc f) &!> StdOut = Proc $ \i o _ pl pw -> f i o o pl pw
(Proc f) &!> (Truncate path) = Proc $ \i o _ pl pw ->
withBinaryFile path WriteMode $ \h -> f i o h pl pw
(Proc f) &!> (Append path) = Proc $ \i o _ pl pw ->
withBinaryFile path AppendMode $ \h -> f i o h pl pw
nativeProc f = Proc $ \i o e pl pw -> handle handler $ do
pl
withDuplicates i o e $ \i' o' e' -> do
(f i' o' e' >>= C.evaluate . force)
`finally` (hClose i')
`finally` (hClose o')
`finally` (hClose e')
`finally` pw
where
handler :: IOError -> IO a
handler e
| ioeGetErrorType e == ResourceVanished = pure (throw e)
| otherwise = throwIO e
writeOutput :: PipeResult io => String -> io ()
writeOutput s = nativeProc $ \_ o _ -> do
hPutStr o s
writeError :: PipeResult io => String -> io ()
writeError s = nativeProc $ \_ _ e -> do
hPutStr e s
readInput :: (NFData a, PipeResult io) => (String -> IO a) -> io a
readInput f = nativeProc $ \i _ _ -> do
hGetContents i >>= f
readInputSplit :: (NFData a, PipeResult io) => String -> ([String] -> IO a) -> io a
readInputSplit s f = readInput (f . split s)
readInputSplit0 :: (NFData a, PipeResult io) => ([String] -> IO a) -> io a
readInputSplit0 = readInputSplit "\0"
readInputLines :: (NFData a, PipeResult io) => ([String] -> IO a) -> io a
readInputLines = readInputSplit "\n"
pureProc :: PipeResult io => (String -> String) -> io ()
pureProc f = nativeProc $ \i o _ -> do
s <- hGetContents i
hPutStr o (f s)
prefixLines :: PipeResult io => String -> io ()
prefixLines s = pureProc $ unlines . map (s ++) . lines
writeProc :: PipeResult io => Proc a -> String -> io a
writeProc p s = writeOutput s |> p
withRead :: (PipeResult f, NFData b) => Proc a -> (String -> IO b) -> f b
withRead p f = p |> readInput f
data Stream = StdOut | StdErr | Truncate FilePath | Append FilePath
devNull :: Stream
devNull = Truncate "/dev/null"
newtype Proc a = Proc (Handle -> Handle -> Handle -> IO () -> IO () -> IO a)
deriving Functor
instance MonadIO Proc where
liftIO a = Proc $ \_ _ _ pl pw -> do
(pl >> a) `finally` pw
instance Semigroup (Proc a) where
(<>) = (|>)
instance (a ~ ()) => Monoid (Proc a) where
mempty = Proc $ \_ _ _ pl pw -> pl `finally` pw
instance Applicative Proc where
pure a = Proc $ \_ _ _ pw pl -> do
pw `finally` pl
pure a
f <*> a = do
f' <- f
a' <- a
pure (f' a')
instance Monad Proc where
(Proc a) >>= f = Proc $ \i o e pl pw -> do
ar <- a i o e pl (pure ())
let
Proc f' = f ar
f' i o e (pure ()) pw
runProc :: Proc a -> IO a
runProc = runProc' stdin stdout stderr
runProc' :: Handle -> Handle -> Handle -> Proc a -> IO a
runProc' i o e (Proc f) = do
r <- f i o e (pure ()) (pure ())
pure $! r
mkProc' :: Bool -> String -> [String] -> Proc ()
mkProc' delegate cmd args = Proc $ \i o e pl pw -> do
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)
$ \(_,_,_,ph) -> do
pl
(waitProc cmd args ph `onException` terminateProcess ph) `finally` pw
mkProc :: String -> [String] -> Proc ()
mkProc = mkProc' False
readProc :: PipeResult io => Proc a -> io String
readProc p = withRead p pure
capture :: PipeResult io => io String
capture = readInput pure
captureTrim :: PipeResult io => io String
captureTrim = readInput (pure . trim)
captureSplit :: PipeResult io => String -> io [String]
captureSplit s = readInput (pure . endBy s)
captureSplit0 :: PipeResult io => io [String]
captureSplit0 = captureSplit "\0"
captureLines :: PipeResult io => io [String]
captureLines = captureSplit "\n"
withRead' :: (NFData b, PipeResult io) => (String -> a) -> Proc x -> (a -> IO b) -> io b
withRead' f p io = withRead p (io . f)
withReadSplit :: (NFData b, PipeResult io) => String -> Proc a -> ([String] -> IO b) -> io b
withReadSplit = withRead' . split
withReadSplit0 :: (NFData b, PipeResult io) => Proc a -> ([String] -> IO b) -> io b
withReadSplit0 = withRead' split0
withReadLines :: (NFData b, PipeResult io) => Proc a -> ([String] -> IO b) -> io b
withReadLines = withRead' lines
withReadWords :: (NFData b, PipeResult io) => Proc a -> ([String] -> IO b) -> io b
withReadWords = withRead' words
readWriteProc :: MonadIO io => Proc a -> String -> io String
readWriteProc p input = liftIO $ readProc p <<< input
apply :: MonadIO io => Proc a -> String -> io String
apply = readWriteProc
(>>>) :: PipeResult io => String -> Proc a -> io a
(>>>) = flip writeProc
(<<<) :: PipeResult io => Proc a -> String -> io a
(<<<) = writeProc
waitProc :: String -> [String] -> ProcessHandle -> IO ()
waitProc cmd arg ph = waitForProcess ph >>= \case
ExitFailure c
| fromIntegral c == negate sigPIPE -> pure ()
| otherwise -> throwIO $ Failure cmd arg c
ExitSuccess -> pure ()
trim :: String -> String
trim = dropWhileEnd isSpace . dropWhile isSpace
class ProcFailure m where
catchFailure :: Proc a -> m (Either Failure a)
instance ProcFailure Proc where
catchFailure (Proc f) = Proc $ \i o e pl pw -> do
try $ f i o e pl pw
instance ProcFailure IO where
catchFailure = runProc . catchFailure
ignoreFailure :: (Functor m, ProcFailure m) => Proc a -> m ()
ignoreFailure = void . catchFailure
catchCode :: (Functor m, ProcFailure m) => Proc a -> m Int
catchCode = fmap getCode . catchFailure
where
getCode (Right _) = 0
getCode (Left f) = failureCode f
readTrim :: (Functor io, PipeResult io) => Proc a -> io String
readTrim = fmap trim . readProc
class ExecArg a where
asArg :: a -> [String]
default asArg :: Show a => a -> [String]
asArg a = [show a]
asArgFromList :: [a] -> [String]
default asArgFromList :: Show a => [a] -> [String]
asArgFromList = concatMap asArg
instance ExecArg Char where
asArg s = [[s]]
asArgFromList s = [s]
instance ExecArg a => ExecArg [a] where
asArg = asArgFromList
asArgFromList = concatMap asArg
instance ExecArg Int
instance ExecArg Integer
instance ExecArg Word
class ExecArgs a where
toArgs :: [String] -> a
instance ExecArgs (Proc ()) where
toArgs (cmd:args) = mkProc cmd args
toArgs _ = error "The impossible happened. How did you construct this?"
instance (ExecArg b, ExecArgs a) => ExecArgs (b -> a) where
toArgs f i = toArgs $ f ++ asArg i
instance ExecArgs (IO ()) where
toArgs = runProc . toArgs
class Unit a
instance {-# OVERLAPPING #-} Unit b => Unit (a -> b)
instance {-# OVERLAPPABLE #-} a ~ () => Unit (m a)
pathBins :: IO [FilePath]
pathBins = map takeFileName <$> pathBinsAbs
pathBinsAbs :: IO [FilePath]
pathBinsAbs = do
pathsVar <- 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 :: (Unit a, ExecArgs a) => String -> a
exe s = toArgs [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 [|
exe executable
|]) []
typn = mkName "a"
typ = SigD name (ForallT [PlainTV typn] [AppT (ConT ''Unit) (VarT typn), AppT (ConT ''ExecArgs) (VarT typn)] (VarT typn))
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
i = go (takeFileName ident)
go (c:cs)
| isLower c = c : go' cs
| isUpper c = toLower c : go' cs
| isNumber c = '_' : go' (c : cs)
| otherwise = go' (c:cs)
go [] = "_"
go' (c:cs)
| isAlphaNum c = c : go' cs
| otherwise = '_' : go' cs
go' [] = []
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 -> [String] -> Q [Dec]
load ref = loadAnnotated ref encodeIdentifier
loadAnnotated :: ExecReference -> (String -> String) -> [String] -> 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)
split :: String -> String -> [String]
split = endBy
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)
split0 :: String -> [String]
split0 = endBy "\0"
readSplit0 :: Proc () -> IO [String]
readSplit0 p = withReadSplit0 p pure
readLines :: Proc () -> IO [String]
readLines p = withReadLines p pure
readWords :: Proc () -> IO [String]
readWords p = withReadWords p pure
readAuto :: Read a => Proc () -> IO a
readAuto p = read <$> readProc p
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) => String -> (String -> Proc a) -> Proc a
xargs1 n f = readInputSplitP n (fmap mconcat . mapM f)
readInputP :: (NFData a, PipeResult io) => (String -> Proc a) -> io a
readInputP f = nativeProc $ \i o e -> do
s <- hGetContents i
withNullInput $ \i' ->
liftIO $ runProc' i' o e (f s)
readInputSplitP :: (NFData a, PipeResult io) => String -> ([String] -> Proc a) -> io a
readInputSplitP s f = readInputP (f . split s)
readInputSplit0P :: (NFData a, PipeResult io) => ([String] -> Proc a) -> io a
readInputSplit0P = readInputSplitP "\0"
readInputLinesP :: (NFData a, PipeResult io) => ([String] -> Proc a) -> io a
readInputLinesP = readInputSplitP "\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