{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE GADTs #-}
module Shh.Internal where
import Control.Concurrent.Async
import Control.DeepSeq (rnf,force,NFData)
import Control.Exception as C
import Control.Monad
import Control.Monad.IO.Class
import Data.Char (isLower, isSpace, isAlphaNum)
import Data.List (nub, dropWhileEnd, intercalate)
import Data.List.Split (endBy, splitOn)
import Data.Maybe (mapMaybe, isJust)
import Language.Haskell.TH
import qualified System.Directory as Dir
import System.Environment (getEnv)
import System.Exit (ExitCode(..))
import System.IO
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 a -> Proc a -> f a
(|!>) :: Proc a -> Proc a -> f a
(&>) :: Proc a -> Stream -> f a
(&!>) :: Proc a -> Stream -> f a
(<|) :: PipeResult f => Proc a -> Proc a -> f a
(<|) = flip (|>)
instance PipeResult IO where
a |> b = runProc $ a |> b
a |!> b = runProc $ a |!> b
a &> s = runProc $ a &> s
a &!> s = runProc $ a &!> s
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
a' <- async $ a i w e (pure ()) (hClose w)
b' <- async $ b r o e (pure ()) (hClose r)
link2 a' b'
(_, br) <- (pl >> waitBoth a' b') `finally` pw
pure br
(Proc a) |!> (Proc b) = Proc $ \i o e pl pw -> do
withPipe $ \r w -> do
a' <- async $ a i o w (pure ()) (hClose w)
b' <- async $ b r o e (pure ()) (hClose r)
link2 a' b'
(_, br) <- (pl >> waitBoth 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
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 (Proc f) = f stdin stdout stderr (pure ()) (pure ())
mkProc :: String -> [String] -> Proc ()
mkProc 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
}
)
(\(_,_,_,ph) -> terminateProcess ph)
$ \(_,_,_,ph) -> do
pl
(waitProc cmd args ph `onException` terminateProcess ph) `finally` pw
readProc :: MonadIO io => Proc a -> io String
readProc p = withRead p pure
withRead :: (NFData b, MonadIO io) => Proc a -> (String -> IO b) -> io b
withRead (Proc f) k = liftIO $
withPipe $ \r w -> do
withAsync (f stdin w stderr (pure ()) (hClose w)) $ \_ ->
(hGetContents r >>= k >>= C.evaluate . force) `finally` hClose r
withRead' :: (NFData b, MonadIO io) => (String -> a) -> Proc x -> (a -> IO b) -> io b
withRead' f p io = withRead p (io . f)
withReadSplit0 :: (NFData b, MonadIO io) => Proc a -> ([String] -> IO b) -> io b
withReadSplit0 = withRead' split0
withReadLines :: (NFData b, MonadIO io) => Proc a -> ([String] -> IO b) -> io b
withReadLines = withRead' lines
withReadWords :: (NFData b, MonadIO io) => Proc a -> ([String] -> IO b) -> io b
withReadWords = withRead' words
readWriteProc :: MonadIO io => Proc a -> String -> io String
readWriteProc (Proc f) input = liftIO $ do
(ri,wi) <- createPipe
(ro,wo) <- createPipe
(_,o) <- concurrently
(concurrently
(f ri wo stderr (pure ()) (hClose wo `finally` hClose ri))
(hPutStr wi input `finally` hClose wi)
) (do
output <- hGetContents ro
C.evaluate $ rnf output
hClose ro
pure output
)
pure o
apply :: MonadIO io => Proc a -> String -> io String
apply = readWriteProc
writeProc :: MonadIO io => Proc a -> String -> io a
writeProc (Proc f) input = liftIO $ do
(r,w) <- createPipe
fst <$> concurrently
(f r stdout stderr (pure ()) (hClose r))
(hPutStr w input `finally` hClose w)
(>>>) :: MonadIO io => String -> Proc a -> io a
(>>>) = flip writeProc
(<<<) :: MonadIO 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 :: MonadIO 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 = do
pathsVar <- splitOn ":" <$> getEnv "PATH"
paths <- filterM Dir.doesDirectoryExist pathsVar
ps <- nub . concat <$> mapM Dir.getDirectoryContents paths
filterM checkExecutable ps
exe :: (Unit a, ExecArgs a) => String -> a
exe s = toArgs [s]
loadExe :: String -> Q [Dec]
loadExe s = loadExeAs s s
loadExeAs :: String -> String -> Q [Dec]
loadExeAs fnName executable =
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))
in do
isExe <- runIO $ checkExecutable executable
when (not isExe) $ error $ "Attempted to load '" ++ executable ++ "', but it isn't executable"
i <- impl
return $ [typ,i]
validIdentifier :: String -> Bool
validIdentifier "" = False
validIdentifier ident = isValidInit (head ident) && all isValidC ident && isNotIdent
where
isValidInit c = isLower c || c `elem` "_"
isValidC c = isAlphaNum c || c `elem` "_'"
isNotIdent = not $ ident `elem`
[ "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", "type", "where"]
loadEnv :: Q [Dec]
loadEnv = loadAnnotatedEnv id
checkExecutable :: FilePath -> IO Bool
checkExecutable = fmap isJust . Dir.findExecutable
load :: [String] -> Q [Dec]
load = loadAnnotated id
loadAnnotated :: (String -> String) -> [String] -> Q [Dec]
loadAnnotated f bins = do
let pairs = mapMaybe getAnnotation bins
ds <- fmap join $ mapM (uncurry loadExeAs) pairs
d <- valD (varP (mkName "missingExecutables")) (normalB [|
filterM (fmap not . checkExecutable) bins
|]) []
pure (d:ds)
where
getAnnotation :: String -> Maybe (String,String)
getAnnotation s
| validIdentifier (f s) = Just (f s, s)
| otherwise = Nothing
loadAnnotatedEnv :: (String -> String) -> Q [Dec]
loadAnnotatedEnv f = do
bins <- runIO pathBins
loadAnnotated f bins
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