{-# LANGUAGE FlexibleInstances #-}
{-# 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.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)
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
(<|) = flip (|>)
(|!>) :: Proc a -> Proc a -> f a
(&>) :: Proc a -> Stream -> f a
(&!>) :: Proc a -> Stream -> f a
writeProc :: Proc a -> String -> f a
withRead :: (NFData b) => Proc a -> (String -> IO b) -> f b
instance PipeResult IO where
a |> b = runProc $ a |> b
a |!> b = runProc $ a |!> b
a &> s = runProc $ a &> s
a &!> s = runProc $ a &!> s
writeProc p s = runProc $ writeProc p s
withRead p k = runProc $ withRead p k
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
writeProc (Proc f) input = Proc $ \_ o e pl pw -> do
withPipe $ \r w ->
fst <$> concurrently
(f r o e pl (pw `finally` hClose r))
(hPutStr w input `finally` hClose w)
withRead (Proc f) k = Proc $ \i _ e pl pw -> do
withPipe $ \r w -> do
withAsync (f i w e pl (hClose w `finally` pw)) $ \_ ->
(hGetContents r >>= k >>= C.evaluate . force) `finally` hClose r
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' :: 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
withRead' :: (NFData b, PipeResult io) => (String -> a) -> Proc x -> (a -> IO b) -> io b
withRead' f p io = withRead p (io . f)
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 = 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 :: ExecReference -> String -> Q [Dec]
loadExe ref s = loadExeAs ref s s
data ExecReference
= Absolute
| SearchPath
loadExeAs :: ExecReference -> String -> String -> Q [Dec]
loadExeAs ref fnName executable =
let
name = mkName $ fnName
impl executableRef = valD (varP name) (normalB [|
exe executableRef
|]) []
typn = mkName "a"
typ = SigD name (ForallT [PlainTV typn] [AppT (ConT ''Unit) (VarT typn), AppT (ConT ''ExecArgs) (VarT typn)] (VarT typn))
in do
runIO (Dir.findExecutable executable) >>= \case
Nothing -> error $ "Attempted to load '" ++ executable ++ "', but it is not executable"
Just absExe -> do
i <- impl (case ref of { Absolute -> absExe; SearchPath -> executable })
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 :: ExecReference -> Q [Dec]
loadEnv ref = loadAnnotatedEnv ref id
checkExecutable :: FilePath -> IO Bool
checkExecutable = fmap isJust . Dir.findExecutable
load :: ExecReference -> [String] -> Q [Dec]
load ref = loadAnnotated ref id
loadAnnotated :: ExecReference -> (String -> String) -> [String] -> Q [Dec]
loadAnnotated ref f bins = do
let pairs = mapMaybe getAnnotation bins
ds <- fmap join $ mapM (uncurry (loadExeAs ref)) 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 :: ExecReference -> (String -> String) -> Q [Dec]
loadAnnotatedEnv ref f = do
bins <- runIO pathBins
loadAnnotated ref 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