module Shelly.Base
(
ShIO, Sh, unSh, runSh, State(..), 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
import Prelude hiding ( FilePath, catch )
import Data.Text.Lazy (Text)
import System.Process( ProcessHandle )
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.Lazy as LT
import qualified Data.Text.Lazy.Builder as B
import qualified Data.Text.Lazy.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)
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 :: FilePath -> [Text] -> Sh (Handle, Handle, Handle, ProcessHandle)
, sEnvironment :: [(String, String)]
, sTracing :: Bool
, sTrace :: B.Builder
, sErrExit :: Bool
}
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 (unpack 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` B.fromLazyText 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 = LT.fromStrict $ case FP.toText fp of
Left f -> f
Right f -> f
inspect :: (Show s) => s -> Sh ()
inspect x = do
(trace . LT.pack . show) x
liftIO $ print x
inspect_err :: (Show s) => s -> Sh ()
inspect_err x = do
let shown = LT.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