module Shelly.Base
(
Sh, ShIO, unSh, runSh, State(..), StdHandle(..), FilePath, Text,
relPath, path, absPath, canonic, canonicalize,
test_d, test_s,
unpack, gets, get, modify, trace,
ls, lsRelAbs,
toTextIgnore,
echo, echo_n, echo_err, echo_n_err, inspect, inspect_err,
catchany,
liftIO, (>=>),
eitherRelativeTo, relativeTo, maybeRelativeTo,
whenM
, addTrailingSlash
) where
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 706
import Prelude hiding (FilePath, catch)
#else
import Prelude hiding (FilePath)
#endif
import Data.Text (Text)
import System.Process( ProcessHandle, StdStream(..) )
import System.IO ( Handle, hFlush, stderr, stdout )
import Control.Monad (when, (>=>) )
import Control.Applicative (Applicative, (<$>))
import Filesystem (isDirectory, listDirectory)
import System.PosixCompat.Files( getSymbolicLinkStatus, isSymbolicLink )
import Filesystem.Path.CurrentOS (FilePath, encodeString, relative)
import qualified Filesystem.Path.CurrentOS as FP
import qualified Filesystem as FS
import Data.IORef (readIORef, modifyIORef, IORef)
import Data.Monoid (mappend)
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import Control.Exception (SomeException, catch)
import Data.Maybe (fromMaybe)
import Control.Monad.Trans ( MonadIO, liftIO )
import Control.Monad.Reader (MonadReader, runReaderT, ask, ReaderT)
import qualified Data.Set as S
type ShIO a = Sh a
newtype Sh a = Sh {
unSh :: ReaderT (IORef State) IO a
} deriving (Applicative, Monad, MonadIO, MonadReader (IORef State), Functor)
runSh :: Sh a -> IORef State -> IO a
runSh = runReaderT . unSh
data State = State
{ sCode :: Int
, sStdin :: Maybe Text
, sStderr :: Text
, sDirectory :: FilePath
, sPrintStdout :: Bool
, sPrintCommands :: Bool
, sRun :: [StdHandle] -> State -> FilePath -> [Text] -> Sh (Handle, Handle, Handle, ProcessHandle)
, sEnvironment :: [(String, String)]
, sPathExecutables :: Maybe [(FilePath, S.Set FilePath)]
, sTracing :: Bool
, sTrace :: Text
, sErrExit :: Bool
}
data StdHandle = InHandle StdStream
| OutHandle StdStream
| ErrorHandle StdStream
whenM :: Monad m => m Bool -> m () -> m ()
whenM c a = c >>= \res -> when res a
relPath :: FilePath -> Sh FilePath
relPath fp = do
wd <- gets sDirectory
rel <- eitherRelativeTo wd fp
return $ case rel of
Right p -> p
Left p -> p
eitherRelativeTo :: FilePath
-> FilePath
-> Sh (Either FilePath FilePath)
eitherRelativeTo relativeFP fp = do
let fullFp = relativeFP FP.</> fp
let relDir = addTrailingSlash relativeFP
stripIt relativeFP fp $
stripIt relativeFP fullFp $
stripIt relDir fp $
stripIt relDir fullFp $ do
relCan <- canonic relDir
fpCan <- canonic fullFp
stripIt relCan fpCan $ return $ Left fpCan
where
stripIt rel toStrip nada =
case FP.stripPrefix rel toStrip of
Just stripped ->
if stripped == toStrip then nada
else return $ Right stripped
Nothing -> nada
relativeTo :: FilePath
-> FilePath
-> Sh FilePath
relativeTo relativeFP fp =
fmap (fromMaybe fp) $ maybeRelativeTo relativeFP fp
maybeRelativeTo :: FilePath
-> FilePath
-> Sh (Maybe FilePath)
maybeRelativeTo relativeFP fp = do
epath <- eitherRelativeTo relativeFP fp
return $ case epath of
Right p -> Just p
Left _ -> Nothing
addTrailingSlash :: FilePath -> FilePath
addTrailingSlash p =
if FP.null (FP.filename p) then p else
p FP.</> FP.empty
canonic :: FilePath -> Sh FilePath
canonic fp = do
p <- absPath fp
liftIO $ canonicalizePath p `catchany` \_ -> return p
canonicalize :: FilePath -> Sh FilePath
canonicalize = absPath >=> liftIO . canonicalizePath
canonicalizePath :: FilePath -> IO FilePath
canonicalizePath p = let was_dir = FP.null (FP.filename p) in
if not was_dir then FS.canonicalizePath p
else addTrailingSlash `fmap` FS.canonicalizePath p
absPath :: FilePath -> Sh FilePath
absPath p | relative p = (FP.</> p) <$> gets sDirectory
| otherwise = return p
path :: FilePath -> Sh FilePath
path = absPath
test_d :: FilePath -> Sh Bool
test_d = absPath >=> liftIO . isDirectory
test_s :: FilePath -> Sh Bool
test_s = absPath >=> liftIO . \f -> do
stat <- getSymbolicLinkStatus (encodeString f)
return $ isSymbolicLink stat
unpack :: FilePath -> String
unpack = encodeString
gets :: (State -> a) -> Sh a
gets f = f <$> get
get :: Sh State
get = do
stateVar <- ask
liftIO (readIORef stateVar)
modify :: (State -> State) -> Sh ()
modify f = do
state <- ask
liftIO (modifyIORef state f)
trace :: Text -> Sh ()
trace msg =
whenM (gets sTracing) $ modify $
\st -> st { sTrace = sTrace st `mappend` msg `mappend` "\n" }
ls :: FilePath -> Sh [FilePath]
ls fp = do
trace $ "ls " `mappend` toTextIgnore fp
fmap fst $ lsRelAbs fp
lsRelAbs :: FilePath -> Sh ([FilePath], [FilePath])
lsRelAbs f = absPath f >>= \fp -> do
filt <- if not (relative f) then return return
else do
wd <- gets sDirectory
return (relativeTo wd)
absolute <- liftIO $ listDirectory fp
relativized <- mapM filt absolute
return (relativized, absolute)
toTextIgnore :: FilePath -> Text
toTextIgnore fp = case FP.toText fp of
Left f -> f
Right f -> f
inspect :: (Show s) => s -> Sh ()
inspect x = do
(trace . T.pack . show) x
liftIO $ print x
inspect_err :: (Show s) => s -> Sh ()
inspect_err x = do
let shown = T.pack $ show x
trace shown
echo_err shown
echo, echo_n, echo_err, echo_n_err :: Text -> Sh ()
echo = traceLiftIO TIO.putStrLn
echo_n = traceLiftIO $ (>> hFlush stdout) . TIO.putStr
echo_err = traceLiftIO $ TIO.hPutStrLn stderr
echo_n_err = traceLiftIO $ (>> hFlush stderr) . TIO.hPutStr stderr
traceLiftIO :: (Text -> IO ()) -> Text -> Sh ()
traceLiftIO f msg = trace ("echo " `mappend` "'" `mappend` msg `mappend` "'") >> liftIO (f msg)
catchany :: IO a -> (SomeException -> IO a) -> IO a
catchany = catch