module Turtle.Prelude (
echo
, err
, readline
, Filesystem.readTextFile
, Filesystem.writeTextFile
, arguments
#if __GLASGOW_HASKELL__ >= 710
, export
, unset
#endif
, need
, env
, cd
, pwd
, home
, realpath
, mv
, mkdir
, mktree
, cp
, cptree
, rm
, rmdir
, rmtree
, testfile
, testdir
, testpath
, date
, datefile
, touch
, time
, hostname
, which
, whichAll
, sleep
, exit
, die
, (.&&.)
, (.||.)
, readonly
, writeonly
, appendonly
, mktemp
, mktempfile
, mktempdir
, fork
, wait
, pushd
, stdin
, input
, inhandle
, stdout
, output
, outhandle
, append
, stderr
, strict
, ls
, lsif
, lstree
, cat
, grep
, sed
, onFiles
, inplace
, find
, yes
, nl
, paste
, endless
, limit
, limitWhile
, cache
, parallel
, single
, countChars
, countWords
, countLines
, cut
, proc
, shell
, procs
, shells
, inproc
, inshell
, inprocWithErr
, inshellWithErr
, procStrict
, shellStrict
, procStrictWithErr
, shellStrictWithErr
, system
, stream
, streamWithErr
, systemStrict
, systemStrictWithErr
, Permissions
, chmod
, getmod
, setmod
, copymod
, readable, nonreadable
, writable, nonwritable
, executable, nonexecutable
, searchable, nonsearchable
, ooo,roo,owo,oox,oos,rwo,rox,ros,owx,rwx,rws
, du
, Size
, sz
, bytes
, kilobytes
, megabytes
, gigabytes
, terabytes
, kibibytes
, mebibytes
, gibibytes
, tebibytes
, PosixCompat.FileStatus
, stat
, lstat
, fileSize
, accessTime
, modificationTime
, statusChangeTime
, PosixCompat.isBlockDevice
, PosixCompat.isCharacterDevice
, PosixCompat.isNamedPipe
, PosixCompat.isRegularFile
, PosixCompat.isDirectory
, PosixCompat.isSymbolicLink
, PosixCompat.isSocket
, WithHeader(..)
, header
, ProcFailed(..)
, ShellFailed(..)
) where
import Control.Applicative
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async
(Async, withAsync, waitSTM, concurrently,
Concurrently(..))
import qualified Control.Concurrent.Async
import Control.Concurrent.MVar (newMVar, modifyMVar_)
import qualified Control.Concurrent.STM as STM
import qualified Control.Concurrent.STM.TQueue as TQueue
import Control.Exception (Exception, bracket, bracket_, finally, mask, throwIO)
import Control.Foldl (Fold, FoldM(..), genericLength, handles, list, premap)
import qualified Control.Foldl
import qualified Control.Foldl.Text
import Control.Monad (guard, liftM, msum, when, unless, (>=>))
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Managed (MonadManaged(..), managed, managed_, runManaged)
#ifdef mingw32_HOST_OS
import Data.Bits ((.&.))
#endif
import Data.IORef (newIORef, readIORef, writeIORef)
import Data.Text (Text, pack, unpack)
import Data.Time (NominalDiffTime, UTCTime, getCurrentTime)
import Data.Time.Clock.POSIX (POSIXTime)
import Data.Traversable
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import Data.Typeable (Typeable)
import qualified Filesystem
import Filesystem.Path.CurrentOS (FilePath, (</>))
import qualified Filesystem.Path.CurrentOS as Filesystem
import GHC.IO.Exception (IOErrorType(UnsupportedOperation))
import Network.HostName (getHostName)
import System.Clock (Clock(..), TimeSpec(..), getTime)
import System.Environment (
getArgs,
#if __GLASGOW_HASKELL__ >= 710
setEnv,
unsetEnv,
#endif
#if __GLASGOW_HASKELL__ >= 708
lookupEnv,
#endif
getEnvironment )
import System.Directory (Permissions)
import qualified System.Directory as Directory
import System.Exit (ExitCode(..), exitWith)
import System.IO (Handle, hClose)
import qualified System.IO as IO
import System.IO.Temp (withTempDirectory, withTempFile)
import System.IO.Error
(catchIOError, ioeGetErrorType, isPermissionError, isDoesNotExistError)
import qualified System.PosixCompat as PosixCompat
import qualified System.Process as Process
#ifdef mingw32_HOST_OS
import qualified System.Win32 as Win32
#else
import System.Posix (
openDirStream,
readDirStream,
closeDirStream,
touchFile )
#endif
import Prelude hiding (FilePath)
import Turtle.Pattern (Pattern, anyChar, chars, match, selfless, sepBy)
import Turtle.Shell
import Turtle.Format (Format, format, makeFormat, d, w, (%))
import Turtle.Internal (ignoreSIGPIPE)
import Turtle.Line
proc
:: MonadIO io
=> Text
-> [Text]
-> Shell Line
-> io ExitCode
proc cmd args =
system
( (Process.proc (unpack cmd) (map unpack args))
{ Process.std_in = Process.CreatePipe
, Process.std_out = Process.Inherit
, Process.std_err = Process.Inherit
} )
shell
:: MonadIO io
=> Text
-> Shell Line
-> io ExitCode
shell cmdLine =
system
( (Process.shell (unpack cmdLine))
{ Process.std_in = Process.CreatePipe
, Process.std_out = Process.Inherit
, Process.std_err = Process.Inherit
} )
data ProcFailed = ProcFailed
{ procCommand :: Text
, procArguments :: [Text]
, procExitCode :: ExitCode
} deriving (Show, Typeable)
instance Exception ProcFailed
procs
:: MonadIO io
=> Text
-> [Text]
-> Shell Line
-> io ()
procs cmd args s = do
exitCode <- proc cmd args s
case exitCode of
ExitSuccess -> return ()
_ -> liftIO (throwIO (ProcFailed cmd args exitCode))
data ShellFailed = ShellFailed
{ shellCommandLine :: Text
, shellExitCode :: ExitCode
} deriving (Show, Typeable)
instance Exception ShellFailed
shells
:: MonadIO io
=> Text
-> Shell Line
-> io ()
shells cmdline s = do
exitCode <- shell cmdline s
case exitCode of
ExitSuccess -> return ()
_ -> liftIO (throwIO (ShellFailed cmdline exitCode))
procStrict
:: MonadIO io
=> Text
-> [Text]
-> Shell Line
-> io (ExitCode, Text)
procStrict cmd args =
systemStrict (Process.proc (Text.unpack cmd) (map Text.unpack args))
shellStrict
:: MonadIO io
=> Text
-> Shell Line
-> io (ExitCode, Text)
shellStrict cmdLine = systemStrict (Process.shell (Text.unpack cmdLine))
procStrictWithErr
:: MonadIO io
=> Text
-> [Text]
-> Shell Line
-> io (ExitCode, Text, Text)
procStrictWithErr cmd args =
systemStrictWithErr (Process.proc (Text.unpack cmd) (map Text.unpack args))
shellStrictWithErr
:: MonadIO io
=> Text
-> Shell Line
-> io (ExitCode, Text, Text)
shellStrictWithErr cmdLine =
systemStrictWithErr (Process.shell (Text.unpack cmdLine))
halt :: Async a -> IO ()
halt a = do
m <- Control.Concurrent.Async.poll a
case m of
Nothing -> Control.Concurrent.Async.cancel a
Just (Left e) -> throwIO e
Just (Right _) -> return ()
system
:: MonadIO io
=> Process.CreateProcess
-> Shell Line
-> io ExitCode
system p s = liftIO (do
let open = do
(m, Nothing, Nothing, ph) <- Process.createProcess p
case m of
Just hIn -> IO.hSetBuffering hIn IO.LineBuffering
_ -> return ()
return (m, ph)
mvar <- newMVar False
let close handle = do
modifyMVar_ mvar (\finalized -> do
unless finalized (ignoreSIGPIPE (hClose handle))
return True )
let close' (Just hIn, ph) = do
close hIn
Process.terminateProcess ph
close' (Nothing , ph) = do
Process.terminateProcess ph
let handle (Just hIn, ph) = do
let feedIn :: (forall a. IO a -> IO a) -> IO ()
feedIn restore =
restore (ignoreSIGPIPE (outhandle hIn s)) `finally` close hIn
mask (\restore ->
withAsync (feedIn restore) (\a ->
restore (Process.waitForProcess ph) `finally` halt a) )
handle (Nothing , ph) = do
Process.waitForProcess ph
bracket open close' handle )
systemStrict
:: MonadIO io
=> Process.CreateProcess
-> Shell Line
-> io (ExitCode, Text)
systemStrict p s = liftIO (do
let p' = p
{ Process.std_in = Process.CreatePipe
, Process.std_out = Process.CreatePipe
, Process.std_err = Process.Inherit
}
let open = do
(Just hIn, Just hOut, Nothing, ph) <- liftIO (Process.createProcess p')
IO.hSetBuffering hIn IO.LineBuffering
return (hIn, hOut, ph)
mvar <- newMVar False
let close handle = do
modifyMVar_ mvar (\finalized -> do
unless finalized (ignoreSIGPIPE (hClose handle))
return True )
bracket open (\(hIn, _, ph) -> close hIn >> Process.terminateProcess ph) (\(hIn, hOut, ph) -> do
let feedIn :: (forall a. IO a -> IO a) -> IO ()
feedIn restore =
restore (ignoreSIGPIPE (outhandle hIn s)) `finally` close hIn
concurrently
(mask (\restore ->
withAsync (feedIn restore) (\a ->
restore (liftIO (Process.waitForProcess ph)) `finally` halt a ) ))
(Text.hGetContents hOut) ) )
systemStrictWithErr
:: MonadIO io
=> Process.CreateProcess
-> Shell Line
-> io (ExitCode, Text, Text)
systemStrictWithErr p s = liftIO (do
let p' = p
{ Process.std_in = Process.CreatePipe
, Process.std_out = Process.CreatePipe
, Process.std_err = Process.CreatePipe
}
let open = do
(Just hIn, Just hOut, Just hErr, ph) <- liftIO (Process.createProcess p')
IO.hSetBuffering hIn IO.LineBuffering
return (hIn, hOut, hErr, ph)
mvar <- newMVar False
let close handle = do
modifyMVar_ mvar (\finalized -> do
unless finalized (ignoreSIGPIPE (hClose handle))
return True )
bracket open (\(hIn, _, _, ph) -> close hIn >> Process.terminateProcess ph) (\(hIn, hOut, hErr, ph) -> do
let feedIn :: (forall a. IO a -> IO a) -> IO ()
feedIn restore =
restore (ignoreSIGPIPE (outhandle hIn s)) `finally` close hIn
runConcurrently $ (,,)
<$> Concurrently (mask (\restore ->
withAsync (feedIn restore) (\a ->
restore (liftIO (Process.waitForProcess ph)) `finally` halt a ) ))
<*> Concurrently (Text.hGetContents hOut)
<*> Concurrently (Text.hGetContents hErr) ) )
inproc
:: Text
-> [Text]
-> Shell Line
-> Shell Line
inproc cmd args = stream (Process.proc (unpack cmd) (map unpack args))
inshell
:: Text
-> Shell Line
-> Shell Line
inshell cmd = stream (Process.shell (unpack cmd))
stream
:: Process.CreateProcess
-> Shell Line
-> Shell Line
stream p s = do
let p' = p
{ Process.std_in = Process.CreatePipe
, Process.std_out = Process.CreatePipe
, Process.std_err = Process.Inherit
}
let open = do
(Just hIn, Just hOut, Nothing, ph) <- liftIO (Process.createProcess p')
IO.hSetBuffering hIn IO.LineBuffering
return (hIn, hOut, ph)
mvar <- liftIO (newMVar False)
let close handle = do
modifyMVar_ mvar (\finalized -> do
unless finalized (hClose handle)
return True )
(hIn, hOut, ph) <- using (managed (bracket open (\(hIn, _, ph) -> close hIn >> Process.terminateProcess ph)))
let feedIn :: (forall a. IO a -> IO a) -> IO ()
feedIn restore = restore (outhandle hIn s) `finally` close hIn
a <- using
(managed (\k ->
mask (\restore -> withAsync (feedIn restore) (restore . k))))
inhandle hOut <|> (liftIO (Process.waitForProcess ph *> halt a) *> empty)
streamWithErr
:: Process.CreateProcess
-> Shell Line
-> Shell (Either Line Line)
streamWithErr p s = do
let p' = p
{ Process.std_in = Process.CreatePipe
, Process.std_out = Process.CreatePipe
, Process.std_err = Process.CreatePipe
}
let open = do
(Just hIn, Just hOut, Just hErr, ph) <- liftIO (Process.createProcess p')
IO.hSetBuffering hIn IO.LineBuffering
return (hIn, hOut, hErr, ph)
mvar <- liftIO (newMVar False)
let close handle = do
modifyMVar_ mvar (\finalized -> do
unless finalized (hClose handle)
return True )
(hIn, hOut, hErr, ph) <- using (managed (bracket open (\(hIn, _, _, ph) -> close hIn >> Process.terminateProcess ph)))
let feedIn :: (forall a. IO a -> IO a) -> IO ()
feedIn restore = restore (outhandle hIn s) `finally` close hIn
queue <- liftIO TQueue.newTQueueIO
let forwardOut :: (forall a. IO a -> IO a) -> IO ()
forwardOut restore =
restore (sh (do
line <- inhandle hOut
liftIO (STM.atomically (TQueue.writeTQueue queue (Just (Right line)))) ))
`finally` STM.atomically (TQueue.writeTQueue queue Nothing)
let forwardErr :: (forall a. IO a -> IO a) -> IO ()
forwardErr restore =
restore (sh (do
line <- inhandle hErr
liftIO (STM.atomically (TQueue.writeTQueue queue (Just (Left line)))) ))
`finally` STM.atomically (TQueue.writeTQueue queue Nothing)
let drain = Shell (\(FoldM step begin done) -> do
x0 <- begin
let loop x numNothing
| numNothing < 2 = do
m <- STM.atomically (TQueue.readTQueue queue)
case m of
Nothing -> loop x $! numNothing + 1
Just e -> do
x' <- step x e
loop x' numNothing
| otherwise = return x
x1 <- loop x0 (0 :: Int)
done x1 )
a <- using
(managed (\k ->
mask (\restore -> withAsync (feedIn restore) (restore . k)) ))
b <- using
(managed (\k ->
mask (\restore -> withAsync (forwardOut restore) (restore . k)) ))
c <- using
(managed (\k ->
mask (\restore -> withAsync (forwardErr restore) (restore . k)) ))
let l `also` r = do
_ <- l <|> (r *> STM.retry)
_ <- r
return ()
let waitAll = STM.atomically (waitSTM a `also` (waitSTM b `also` waitSTM c))
drain <|> (liftIO (Process.waitForProcess ph *> waitAll) *> empty)
inprocWithErr
:: Text
-> [Text]
-> Shell Line
-> Shell (Either Line Line)
inprocWithErr cmd args =
streamWithErr (Process.proc (unpack cmd) (map unpack args))
inshellWithErr
:: Text
-> Shell Line
-> Shell (Either Line Line)
inshellWithErr cmd = streamWithErr (Process.shell (unpack cmd))
echo :: MonadIO io => Line -> io ()
echo line = liftIO (Text.putStrLn (lineToText line))
err :: MonadIO io => Line -> io ()
err line = liftIO (Text.hPutStrLn IO.stderr (lineToText line))
readline :: MonadIO io => io (Maybe Line)
readline = liftIO (do
eof <- IO.isEOF
if eof
then return Nothing
else fmap (Just . unsafeTextToLine . pack) getLine )
arguments :: MonadIO io => io [Text]
arguments = liftIO (fmap (map pack) getArgs)
#if __GLASGOW_HASKELL__ >= 710
export :: MonadIO io => Text -> Text -> io ()
export key val = liftIO (setEnv (unpack key) (unpack val))
unset :: MonadIO io => Text -> io ()
unset key = liftIO (unsetEnv (unpack key))
#endif
need :: MonadIO io => Text -> io (Maybe Text)
#if __GLASGOW_HASKELL__ >= 708
need key = liftIO (fmap (fmap pack) (lookupEnv (unpack key)))
#else
need key = liftM (lookup key) env
#endif
env :: MonadIO io => io [(Text, Text)]
env = liftIO (fmap (fmap toTexts) getEnvironment)
where
toTexts (key, val) = (pack key, pack val)
cd :: MonadIO io => FilePath -> io ()
cd path = liftIO (Filesystem.setWorkingDirectory path)
pushd :: MonadManaged managed => FilePath -> managed ()
pushd path = do
cwd <- pwd
using (managed_ (bracket_ (cd path) (cd cwd)))
pwd :: MonadIO io => io FilePath
pwd = liftIO Filesystem.getWorkingDirectory
home :: MonadIO io => io FilePath
home = liftIO Filesystem.getHomeDirectory
realpath :: MonadIO io => FilePath -> io FilePath
realpath path = liftIO (Filesystem.canonicalizePath path)
#ifdef mingw32_HOST_OS
fILE_ATTRIBUTE_REPARSE_POINT :: Win32.FileAttributeOrFlag
fILE_ATTRIBUTE_REPARSE_POINT = 1024
reparsePoint :: Win32.FileAttributeOrFlag -> Bool
reparsePoint attr = fILE_ATTRIBUTE_REPARSE_POINT .&. attr /= 0
#endif
ls :: FilePath -> Shell FilePath
ls path = Shell (\(FoldM step begin done) -> do
x0 <- begin
let path' = Filesystem.encodeString path
canRead <- fmap
Directory.readable
(Directory.getPermissions (deslash path'))
#ifdef mingw32_HOST_OS
reparse <- fmap reparsePoint (Win32.getFileAttributes path')
if (canRead && not reparse)
then bracket
(Win32.findFirstFile (Filesystem.encodeString (path </> "*")))
(\(h, _) -> Win32.findClose h)
(\(h, fdat) -> do
let loop x = do
file' <- Win32.getFindDataFileName fdat
let file = Filesystem.decodeString file'
x' <- if (file' /= "." && file' /= "..")
then step x (path </> file)
else return x
more <- Win32.findNextFile h fdat
if more then loop $! x' else done x'
loop $! x0 )
else done x0 )
#else
if canRead
then bracket (openDirStream path') closeDirStream (\dirp -> do
let loop x = do
file' <- readDirStream dirp
case file' of
"" -> done x
_ -> do
let file = Filesystem.decodeString file'
x' <- if (file' /= "." && file' /= "..")
then step x (path </> file)
else return x
loop $! x'
loop $! x0 )
else done x0 )
#endif
deslash :: String -> String
deslash [] = []
deslash (c0:cs0) = c0:go cs0
where
go [] = []
go ['\\'] = []
go (c:cs) = c:go cs
lstree :: FilePath -> Shell FilePath
lstree path = do
child <- ls path
isDir <- testdir child
if isDir
then return child <|> lstree child
else return child
lsif :: (FilePath -> IO Bool) -> FilePath -> Shell FilePath
lsif predicate path = do
child <- ls path
isDir <- testdir child
if isDir
then do
continue <- liftIO (predicate child)
if continue
then return child <|> lsif predicate child
else return child
else return child
mv :: MonadIO io => FilePath -> FilePath -> io ()
mv oldPath newPath = liftIO $ catchIOError (Filesystem.rename oldPath newPath)
(\ioe -> if ioeGetErrorType ioe == UnsupportedOperation
then do
Filesystem.copyFile oldPath newPath
Filesystem.removeFile oldPath
else ioError ioe)
mkdir :: MonadIO io => FilePath -> io ()
mkdir path = liftIO (Filesystem.createDirectory False path)
mktree :: MonadIO io => FilePath -> io ()
mktree path = liftIO (Filesystem.createTree path)
cp :: MonadIO io => FilePath -> FilePath -> io ()
cp oldPath newPath = liftIO (Filesystem.copyFile oldPath newPath)
cptree :: MonadIO io => FilePath -> FilePath -> io ()
cptree oldTree newTree = sh (do
oldPath <- lstree oldTree
Just suffix <- return (Filesystem.stripPrefix (oldTree </> "") oldPath)
let newPath = newTree </> suffix
isFile <- testfile oldPath
if isFile
then mktree (Filesystem.directory newPath) >> cp oldPath newPath
else mktree newPath )
rm :: MonadIO io => FilePath -> io ()
rm path = liftIO (Filesystem.removeFile path)
rmdir :: MonadIO io => FilePath -> io ()
rmdir path = liftIO (Filesystem.removeDirectory path)
rmtree :: MonadIO io => FilePath -> io ()
rmtree path0 = liftIO (sh (loop path0))
where
loop path = do
linkstat <- lstat path
let isLink = PosixCompat.isSymbolicLink linkstat
isDir = PosixCompat.isDirectory linkstat
if isLink
then rm path
else do
if isDir
then (do
child <- ls path
loop child ) <|> rmdir path
else rm path
testfile :: MonadIO io => FilePath -> io Bool
testfile path = liftIO (Filesystem.isFile path)
testdir :: MonadIO io => FilePath -> io Bool
testdir path = liftIO (Filesystem.isDirectory path)
testpath :: MonadIO io => FilePath -> io Bool
testpath path = do
exists <- testfile path
if exists
then return exists
else testdir path
touch :: MonadIO io => FilePath -> io ()
touch file = do
exists <- testfile file
liftIO (if exists
#ifdef mingw32_HOST_OS
then do
handle <- Win32.createFile
(Filesystem.encodeString file)
Win32.gENERIC_WRITE
Win32.fILE_SHARE_NONE
Nothing
Win32.oPEN_EXISTING
Win32.fILE_ATTRIBUTE_NORMAL
Nothing
(creationTime, _, _) <- Win32.getFileTime handle
systemTime <- Win32.getSystemTimeAsFileTime
Win32.setFileTime handle creationTime systemTime systemTime
#else
then touchFile (Filesystem.encodeString file)
#endif
else output file empty )
chmod
:: MonadIO io
=> (Permissions -> Permissions)
-> FilePath
-> io Permissions
chmod modifyPermissions path = liftIO (do
let path' = deslash (Filesystem.encodeString path)
permissions <- Directory.getPermissions path'
let permissions' = modifyPermissions permissions
changed = permissions /= permissions'
when changed (Directory.setPermissions path' permissions')
return permissions' )
getmod :: MonadIO io => FilePath -> io Permissions
getmod path = liftIO (do
let path' = deslash (Filesystem.encodeString path)
Directory.getPermissions path' )
setmod :: MonadIO io => Permissions -> FilePath -> io ()
setmod permissions path = liftIO (do
let path' = deslash (Filesystem.encodeString path)
Directory.setPermissions path' permissions )
copymod :: MonadIO io => FilePath -> FilePath -> io ()
copymod sourcePath targetPath = liftIO (do
let sourcePath' = deslash (Filesystem.encodeString sourcePath)
targetPath' = deslash (Filesystem.encodeString targetPath)
Directory.copyPermissions sourcePath' targetPath' )
readable :: Permissions -> Permissions
readable = Directory.setOwnerReadable True
nonreadable :: Permissions -> Permissions
nonreadable = Directory.setOwnerReadable False
writable :: Permissions -> Permissions
writable = Directory.setOwnerWritable True
nonwritable :: Permissions -> Permissions
nonwritable = Directory.setOwnerWritable False
executable :: Permissions -> Permissions
executable = Directory.setOwnerExecutable True
nonexecutable :: Permissions -> Permissions
nonexecutable = Directory.setOwnerExecutable False
searchable :: Permissions -> Permissions
searchable = Directory.setOwnerSearchable True
nonsearchable :: Permissions -> Permissions
nonsearchable = Directory.setOwnerSearchable False
ooo :: Permissions -> Permissions
ooo = const Directory.emptyPermissions
roo :: Permissions -> Permissions
roo = readable . ooo
owo :: Permissions -> Permissions
owo = writable . ooo
oox :: Permissions -> Permissions
oox = executable . ooo
oos :: Permissions -> Permissions
oos = searchable . ooo
rwo :: Permissions -> Permissions
rwo = readable . writable . ooo
rox :: Permissions -> Permissions
rox = readable . executable . ooo
ros :: Permissions -> Permissions
ros = readable . searchable . ooo
owx :: Permissions -> Permissions
owx = writable . executable . ooo
rwx :: Permissions -> Permissions
rwx = readable . writable . executable . ooo
rws :: Permissions -> Permissions
rws = readable . writable . searchable . ooo
time :: MonadIO io => io a -> io (a, NominalDiffTime)
time io = do
TimeSpec seconds1 nanoseconds1 <- liftIO (getTime Monotonic)
a <- io
TimeSpec seconds2 nanoseconds2 <- liftIO (getTime Monotonic)
let t = fromIntegral ( seconds2 seconds1)
+ fromIntegral (nanoseconds2 nanoseconds1) / 10^(9::Int)
return (a, fromRational t)
hostname :: MonadIO io => io Text
hostname = liftIO (fmap Text.pack getHostName)
which :: MonadIO io => FilePath -> io (Maybe FilePath)
which cmd = fold (whichAll cmd) Control.Foldl.head
whichAll :: FilePath -> Shell FilePath
whichAll cmd = do
Just paths <- need "PATH"
path <- select (Filesystem.splitSearchPathString . Text.unpack $ paths)
let path' = path </> cmd
True <- testfile path'
let handler :: IOError -> IO Permissions
handler e =
if isPermissionError e || isDoesNotExistError e
then return Directory.emptyPermissions
else throwIO e
perms <- liftIO (getmod path' `catchIOError` handler)
guard (Directory.executable perms)
return path'
sleep :: MonadIO io => NominalDiffTime -> io ()
sleep n = liftIO (threadDelay (truncate (n * 10^(6::Int))))
exit :: MonadIO io => ExitCode -> io a
exit code = liftIO (exitWith code)
die :: MonadIO io => Text -> io a
die txt = liftIO (throwIO (userError (unpack txt)))
infixr 2 .||.
infixr 3 .&&.
(.&&.) :: Monad m => m ExitCode -> m ExitCode -> m ExitCode
cmd1 .&&. cmd2 = do
r <- cmd1
case r of
ExitSuccess -> cmd2
_ -> return r
(.||.) :: Monad m => m ExitCode -> m ExitCode -> m ExitCode
cmd1 .||. cmd2 = do
r <- cmd1
case r of
ExitFailure _ -> cmd2
_ -> return r
mktempdir
:: MonadManaged managed
=> FilePath
-> Text
-> managed FilePath
mktempdir parent prefix = using (do
let parent' = Filesystem.encodeString parent
let prefix' = unpack prefix
dir' <- managed (withTempDirectory parent' prefix')
return (Filesystem.decodeString dir'))
mktemp
:: MonadManaged managed
=> FilePath
-> Text
-> managed (FilePath, Handle)
mktemp parent prefix = using (do
let parent' = Filesystem.encodeString parent
let prefix' = unpack prefix
(file', handle) <- managed (\k ->
withTempFile parent' prefix' (\file' handle -> k (file', handle)) )
return (Filesystem.decodeString file', handle) )
mktempfile
:: MonadManaged managed
=> FilePath
-> Text
-> managed FilePath
mktempfile parent prefix = using (do
let parent' = Filesystem.encodeString parent
let prefix' = unpack prefix
(file', handle) <- managed (\k ->
withTempFile parent' prefix' (\file' handle -> k (file', handle)) )
liftIO (hClose handle)
return (Filesystem.decodeString file') )
fork :: MonadManaged managed => IO a -> managed (Async a)
fork io = using (managed (withAsync io))
wait :: MonadIO io => Async a -> io a
wait a = liftIO (Control.Concurrent.Async.wait a)
stdin :: Shell Line
stdin = inhandle IO.stdin
input :: FilePath -> Shell Line
input file = do
handle <- using (readonly file)
inhandle handle
inhandle :: Handle -> Shell Line
inhandle handle = Shell (\(FoldM step begin done) -> do
x0 <- begin
let loop x = do
eof <- IO.hIsEOF handle
if eof
then done x
else do
txt <- Text.hGetLine handle
x' <- step x (unsafeTextToLine txt)
loop $! x'
loop $! x0 )
stdout :: MonadIO io => Shell Line -> io ()
stdout s = sh (do
line <- s
liftIO (echo line) )
output :: MonadIO io => FilePath -> Shell Line -> io ()
output file s = sh (do
handle <- using (writeonly file)
line <- s
liftIO (Text.hPutStrLn handle (lineToText line)) )
outhandle :: MonadIO io => Handle -> Shell Line -> io ()
outhandle handle s = sh (do
line <- s
liftIO (Text.hPutStrLn handle (lineToText line)) )
append :: MonadIO io => FilePath -> Shell Line -> io ()
append file s = sh (do
handle <- using (appendonly file)
line <- s
liftIO (Text.hPutStrLn handle (lineToText line)) )
stderr :: MonadIO io => Shell Line -> io ()
stderr s = sh (do
line <- s
liftIO (err line) )
strict :: MonadIO io => Shell Line -> io Text
strict s = liftM linesToText (fold s list)
readonly :: MonadManaged managed => FilePath -> managed Handle
readonly file = using (managed (Filesystem.withTextFile file IO.ReadMode))
writeonly :: MonadManaged managed => FilePath -> managed Handle
writeonly file = using (managed (Filesystem.withTextFile file IO.WriteMode))
appendonly :: MonadManaged managed => FilePath -> managed Handle
appendonly file = using (managed (Filesystem.withTextFile file IO.AppendMode))
cat :: [Shell a] -> Shell a
cat = msum
grep :: Pattern a -> Shell Line -> Shell Line
grep pattern s = do
line <- s
_:_ <- return (match pattern (lineToText line))
return line
sed :: Pattern Text -> Shell Line -> Shell Line
sed pattern s = do
when (matchesEmpty pattern) (die message)
let pattern' = fmap Text.concat
(many (pattern <|> fmap Text.singleton anyChar))
line <- s
txt':_ <- return (match pattern' (lineToText line))
select (textToLines txt')
where
message = "sed: the given pattern matches the empty string"
matchesEmpty = not . null . flip match ""
onFiles :: (Shell Text -> Shell Text) -> Shell FilePath -> Shell FilePath
onFiles f = fmap Filesystem.fromText . f . getRights . fmap Filesystem.toText
where
getRights :: forall a. Shell (Either a Text) -> Shell Text
getRights s = s >>= either (const empty) return
inplace :: MonadIO io => Pattern Text -> FilePath -> io ()
inplace pattern file = liftIO (runManaged (do
here <- pwd
(tmpfile, handle) <- mktemp here "turtle"
outhandle handle (sed pattern (input file))
liftIO (hClose handle)
copymod file tmpfile
mv tmpfile file ))
find :: Pattern a -> FilePath -> Shell FilePath
find pattern dir = do
path <- lsif isNotSymlink dir
Right txt <- return (Filesystem.toText path)
_:_ <- return (match pattern txt)
return path
where
isNotSymlink :: FilePath -> IO Bool
isNotSymlink file = do
file_stat <- lstat file
return (not (PosixCompat.isSymbolicLink file_stat))
yes :: Shell Line
yes = fmap (\_ -> "y") endless
nl :: Num n => Shell a -> Shell (n, a)
nl s = Shell _foldIO'
where
_foldIO' (FoldM step begin done) = _foldIO s (FoldM step' begin' done')
where
step' (x, n) a = do
x' <- step x (n, a)
let n' = n + 1
n' `seq` return (x', n')
begin' = do
x0 <- begin
return (x0, 0)
done' (x, _) = done x
data ZipState a b = Empty | HasA a | HasAB a b | Done
paste :: Shell a -> Shell b -> Shell (a, b)
paste sA sB = Shell _foldIOAB
where
_foldIOAB (FoldM stepAB beginAB doneAB) = do
x0 <- beginAB
tvar <- STM.atomically (STM.newTVar Empty)
let begin = return ()
let stepA () a = STM.atomically (do
x <- STM.readTVar tvar
case x of
Empty -> STM.writeTVar tvar (HasA a)
Done -> return ()
_ -> STM.retry )
let doneA () = STM.atomically (do
x <- STM.readTVar tvar
case x of
Empty -> STM.writeTVar tvar Done
Done -> return ()
_ -> STM.retry )
let foldA = FoldM stepA begin doneA
let stepB () b = STM.atomically (do
x <- STM.readTVar tvar
case x of
HasA a -> STM.writeTVar tvar (HasAB a b)
Done -> return ()
_ -> STM.retry )
let doneB () = STM.atomically (do
x <- STM.readTVar tvar
case x of
HasA _ -> STM.writeTVar tvar Done
Done -> return ()
_ -> STM.retry )
let foldB = FoldM stepB begin doneB
withAsync (foldIO sA foldA) (\asyncA -> do
withAsync (foldIO sB foldB) (\asyncB -> do
let loop x = do
y <- STM.atomically (do
z <- STM.readTVar tvar
case z of
HasAB a b -> do
STM.writeTVar tvar Empty
return (Just (a, b))
Done -> return Nothing
_ -> STM.retry )
case y of
Nothing -> return x
Just ab -> do
x' <- stepAB x ab
loop $! x'
x' <- loop $! x0
wait asyncA
wait asyncB
doneAB x' ) )
endless :: Shell ()
endless = Shell (\(FoldM step begin _) -> do
x0 <- begin
let loop x = do
x' <- step x ()
loop $! x'
loop $! x0 )
limit :: Int -> Shell a -> Shell a
limit n s = Shell (\(FoldM step begin done) -> do
ref <- newIORef 0
let step' x a = do
n' <- readIORef ref
writeIORef ref (n' + 1)
if n' < n then step x a else return x
foldIO s (FoldM step' begin done) )
limitWhile :: (a -> Bool) -> Shell a -> Shell a
limitWhile predicate s = Shell (\(FoldM step begin done) -> do
ref <- newIORef True
let step' x a = do
b <- readIORef ref
let b' = b && predicate a
writeIORef ref b'
if b' then step x a else return x
foldIO s (FoldM step' begin done) )
cache :: (Read a, Show a) => FilePath -> Shell a -> Shell a
cache file s = do
let cached = do
line <- input file
case reads (Text.unpack (lineToText line)) of
[(ma, "")] -> return ma
_ ->
die (format ("cache: Invalid data stored in "%w) file)
exists <- testfile file
mas <- fold (if exists then cached else empty) list
case [ () | Nothing <- mas ] of
_:_ -> select [ a | Just a <- mas ]
_ -> do
handle <- using (writeonly file)
let justs = do
a <- s
liftIO (Text.hPutStrLn handle (Text.pack (show (Just a))))
return a
let nothing = do
let n = Nothing :: Maybe ()
liftIO (Text.hPutStrLn handle (Text.pack (show n)))
empty
justs <|> nothing
parallel :: [IO a] -> Shell a
parallel = traverse fork >=> select >=> wait
cut :: Pattern a -> Text -> [Text]
cut pattern txt = head (match (selfless chars `sepBy` pattern) txt)
date :: MonadIO io => io UTCTime
date = liftIO getCurrentTime
datefile :: MonadIO io => FilePath -> io UTCTime
datefile path = liftIO (Filesystem.getModified path)
du :: MonadIO io => FilePath -> io Size
du path = liftIO (do
isDir <- testdir path
size <- do
if isDir
then do
let sizes = do
child <- lstree path
True <- testfile child
liftIO (Filesystem.getSize child)
fold sizes Control.Foldl.sum
else Filesystem.getSize path
return (Size size) )
newtype Size = Size { _bytes :: Integer } deriving (Eq, Ord, Num)
instance Show Size where
show = show . _bytes
sz :: Format r (Size -> r)
sz = makeFormat (\(Size numBytes) ->
let (numKilobytes, remainingBytes ) = numBytes `quotRem` 1000
(numMegabytes, remainingKilobytes) = numKilobytes `quotRem` 1000
(numGigabytes, remainingMegabytes) = numMegabytes `quotRem` 1000
(numTerabytes, remainingGigabytes) = numGigabytes `quotRem` 1000
in if numKilobytes <= 0
then format (d%" B" ) remainingBytes
else if numMegabytes == 0
then format (d%"."%d%" KB") remainingKilobytes remainingBytes
else if numGigabytes == 0
then format (d%"."%d%" MB") remainingMegabytes remainingKilobytes
else if numTerabytes == 0
then format (d%"."%d%" GB") remainingGigabytes remainingMegabytes
else format (d%"."%d%" TB") numTerabytes remainingGigabytes )
bytes :: Integral n => Size -> n
bytes = fromInteger . _bytes
kilobytes :: Integral n => Size -> n
kilobytes = (`div` 1000) . bytes
megabytes :: Integral n => Size -> n
megabytes = (`div` 1000) . kilobytes
gigabytes :: Integral n => Size -> n
gigabytes = (`div` 1000) . megabytes
terabytes :: Integral n => Size -> n
terabytes = (`div` 1000) . gigabytes
kibibytes :: Integral n => Size -> n
kibibytes = (`div` 1024) . bytes
mebibytes :: Integral n => Size -> n
mebibytes = (`div` 1024) . kibibytes
gibibytes :: Integral n => Size -> n
gibibytes = (`div` 1024) . mebibytes
tebibytes :: Integral n => Size -> n
tebibytes = (`div` 1024) . gibibytes
countChars :: Integral n => Fold Line n
countChars =
premap lineToText Control.Foldl.Text.length +
charsPerNewline * countLines
charsPerNewline :: Num a => a
#ifdef mingw32_HOST_OS
charsPerNewline = 2
#else
charsPerNewline = 1
#endif
countWords :: Integral n => Fold Line n
countWords = premap (Text.words . lineToText) (handles traverse genericLength)
countLines :: Integral n => Fold Line n
countLines = genericLength
stat :: MonadIO io => FilePath -> io PosixCompat.FileStatus
stat = liftIO . PosixCompat.getFileStatus . Filesystem.encodeString
fileSize :: PosixCompat.FileStatus -> Size
fileSize = fromIntegral . PosixCompat.fileSize
accessTime :: PosixCompat.FileStatus -> POSIXTime
accessTime = realToFrac . PosixCompat.accessTime
modificationTime :: PosixCompat.FileStatus -> POSIXTime
modificationTime = realToFrac . PosixCompat.modificationTime
statusChangeTime :: PosixCompat.FileStatus -> POSIXTime
statusChangeTime = realToFrac . PosixCompat.statusChangeTime
lstat :: MonadIO io => FilePath -> io PosixCompat.FileStatus
lstat = liftIO . PosixCompat.getSymbolicLinkStatus . Filesystem.encodeString
data WithHeader a
= Header a
| Row a a
deriving (Show)
data Pair a b = Pair !a !b
header :: Shell a -> Shell (WithHeader a)
header (Shell k) = Shell k'
where
k' (FoldM step begin done) = k (FoldM step' begin' done')
where
step' (Pair x Nothing ) a = do
x' <- step x (Header a)
return (Pair x' (Just a))
step' (Pair x (Just a)) b = do
x' <- step x (Row a b)
return (Pair x' (Just a))
begin' = do
x <- begin
return (Pair x Nothing)
done' (Pair x _) = done x
single :: MonadIO io => Shell a -> io (Maybe a)
single s = do
as <- fold s Control.Foldl.list
case as of
[a] -> return (Just a)
_ -> do
let msg = format ("single: expected 1 line of input but there were "%d%" lines of input") (length as)
die msg