1{-# LANGUAGE CPP #-} 2{-# LANGUAGE DeriveDataTypeable #-} 3{-# LANGUAGE OverloadedStrings #-} 4{-# LANGUAGE GeneralizedNewtypeDeriving #-} 5{-# LANGUAGE RankNTypes #-} 6{-# LANGUAGE TupleSections #-} 7{-# LANGUAGE PatternSynonyms #-} 8{-# LANGUAGE ViewPatterns #-} 9 10-- | This module provides a large suite of utilities that resemble Unix 11-- utilities. 12-- 13-- Many of these commands are just existing Haskell commands renamed to match 14-- their Unix counterparts: 15-- 16-- >>> :set -XOverloadedStrings 17-- >>> cd "/tmp" 18-- >>> pwd 19-- FilePath "/tmp" 20-- 21-- Some commands are `Shell`s that emit streams of values. `view` prints all 22-- values in a `Shell` stream: 23-- 24-- >>> view (ls "/usr") 25-- FilePath "/usr/lib" 26-- FilePath "/usr/src" 27-- FilePath "/usr/sbin" 28-- FilePath "/usr/include" 29-- FilePath "/usr/share" 30-- FilePath "/usr/games" 31-- FilePath "/usr/local" 32-- FilePath "/usr/bin" 33-- >>> view (find (suffix "Browser.py") "/usr/lib") 34-- FilePath "/usr/lib/python3.4/idlelib/ClassBrowser.py" 35-- FilePath "/usr/lib/python3.4/idlelib/RemoteObjectBrowser.py" 36-- FilePath "/usr/lib/python3.4/idlelib/PathBrowser.py" 37-- FilePath "/usr/lib/python3.4/idlelib/ObjectBrowser.py" 38-- 39-- Use `fold` to reduce the output of a `Shell` stream: 40-- 41-- >>> import qualified Control.Foldl as Fold 42-- >>> fold (ls "/usr") Fold.length 43-- 8 44-- >>> fold (find (suffix "Browser.py") "/usr/lib") Fold.head 45-- Just (FilePath "/usr/lib/python3.4/idlelib/ClassBrowser.py") 46-- 47-- Create files using `output`: 48-- 49-- >>> output "foo.txt" ("123" <|> "456" <|> "ABC") 50-- >>> realpath "foo.txt" 51-- FilePath "/tmp/foo.txt" 52-- 53-- Read in files using `input`: 54-- 55-- >>> stdout (input "foo.txt") 56-- 123 57-- 456 58-- ABC 59-- 60-- Format strings in a type safe way using `format`: 61-- 62-- >>> dir <- pwd 63-- >>> format ("I am in the "%fp%" directory") dir 64-- "I am in the /tmp directory" 65-- 66-- Commands like `grep`, `sed` and `find` accept arbitrary `Pattern`s 67-- 68-- >>> stdout (grep ("123" <|> "ABC") (input "foo.txt")) 69-- 123 70-- ABC 71-- >>> let exclaim = fmap (<> "!") (plus digit) 72-- >>> stdout (sed exclaim (input "foo.txt")) 73-- 123! 74-- 456! 75-- ABC 76-- 77-- Note that `grep` and `find` differ from their Unix counterparts by requiring 78-- that the `Pattern` matches the entire line or file name by default. However, 79-- you can optionally match the prefix, suffix, or interior of a line: 80-- 81-- >>> stdout (grep (has "2") (input "foo.txt")) 82-- 123 83-- >>> stdout (grep (prefix "1") (input "foo.txt")) 84-- 123 85-- >>> stdout (grep (suffix "3") (input "foo.txt")) 86-- 123 87-- 88-- You can also build up more sophisticated `Shell` programs using `sh` in 89-- conjunction with @do@ notation: 90-- 91-- >{-# LANGUAGE OverloadedStrings #-} 92-- > 93-- >import Turtle 94-- > 95-- >main = sh example 96-- > 97-- >example = do 98-- > -- Read in file names from "files1.txt" and "files2.txt" 99-- > file <- fmap fromText (input "files1.txt" <|> input "files2.txt") 100-- > 101-- > -- Stream each file to standard output only if the file exists 102-- > True <- liftIO (testfile file) 103-- > line <- input file 104-- > liftIO (echo line) 105-- 106-- See "Turtle.Tutorial" for an extended tutorial explaining how to use this 107-- library in greater detail. 108 109module Turtle.Prelude ( 110 -- * IO 111 echo 112 , err 113 , readline 114 , Filesystem.readTextFile 115 , Filesystem.writeTextFile 116 , arguments 117#if __GLASGOW_HASKELL__ >= 710 118 , export 119 , unset 120#endif 121 , need 122 , env 123 , cd 124 , pwd 125 , home 126 , readlink 127 , realpath 128 , mv 129 , mkdir 130 , mktree 131 , cp 132 , cptree 133 , cptreeL 134#if !defined(mingw32_HOST_OS) 135 , symlink 136#endif 137 , isNotSymbolicLink 138 , rm 139 , rmdir 140 , rmtree 141 , testfile 142 , testdir 143 , testpath 144 , date 145 , datefile 146 , touch 147 , time 148 , hostname 149 , which 150 , whichAll 151 , sleep 152 , exit 153 , die 154 , (.&&.) 155 , (.||.) 156 157 -- * Managed 158 , readonly 159 , writeonly 160 , appendonly 161 , mktemp 162 , mktempfile 163 , mktempdir 164 , fork 165 , wait 166 , pushd 167 168 -- * Shell 169 , stdin 170 , input 171 , inhandle 172 , stdout 173 , output 174 , outhandle 175 , append 176 , stderr 177 , strict 178 , ls 179 , lsif 180 , lstree 181 , lsdepth 182 , cat 183 , grep 184 , grepText 185 , sed 186 , sedPrefix 187 , sedSuffix 188 , sedEntire 189 , onFiles 190 , inplace 191 , inplacePrefix 192 , inplaceSuffix 193 , inplaceEntire 194 , update 195 , find 196 , findtree 197 , yes 198 , nl 199 , paste 200 , endless 201 , limit 202 , limitWhile 203 , cache 204 , parallel 205 , single 206 , uniq 207 , uniqOn 208 , uniqBy 209 , nub 210 , nubOn 211 , sort 212 , sortOn 213 , sortBy 214 , toLines 215 216 -- * Folds 217 , countChars 218 , countWords 219 , countLines 220 221 -- * Text 222 , cut 223 224 -- * Subprocess management 225 , proc 226 , shell 227 , procs 228 , shells 229 , inproc 230 , inshell 231 , inprocWithErr 232 , inshellWithErr 233 , procStrict 234 , shellStrict 235 , procStrictWithErr 236 , shellStrictWithErr 237 238 , system 239 , stream 240 , streamWithErr 241 , systemStrict 242 , systemStrictWithErr 243 244 -- * Permissions 245 , Permissions(..) 246 , chmod 247 , getmod 248 , setmod 249 , copymod 250 , readable, nonreadable 251 , writable, nonwritable 252 , executable, nonexecutable 253 , ooo,roo,owo,oox,rwo,rox,owx,rwx 254 255 -- * File size 256 , du 257 , Size(B, KB, MB, GB, TB, KiB, MiB, GiB, TiB) 258 , sz 259 , bytes 260 , kilobytes 261 , megabytes 262 , gigabytes 263 , terabytes 264 , kibibytes 265 , mebibytes 266 , gibibytes 267 , tebibytes 268 269 -- * File status 270 , PosixCompat.FileStatus 271 , stat 272 , lstat 273 , fileSize 274 , accessTime 275 , modificationTime 276 , statusChangeTime 277 , PosixCompat.isBlockDevice 278 , PosixCompat.isCharacterDevice 279 , PosixCompat.isNamedPipe 280 , PosixCompat.isRegularFile 281 , PosixCompat.isDirectory 282 , PosixCompat.isSymbolicLink 283 , PosixCompat.isSocket 284 , cmin 285 , cmax 286 287 -- * Headers 288 , WithHeader(..) 289 , header 290 291 -- * Exceptions 292 , ProcFailed(..) 293 , ShellFailed(..) 294 ) where 295 296import Control.Applicative 297import Control.Concurrent (threadDelay) 298import Control.Concurrent.Async 299 (Async, withAsync, waitSTM, concurrently, 300 Concurrently(..)) 301import qualified Control.Concurrent.Async 302import Control.Concurrent.MVar (newMVar, modifyMVar_) 303import qualified Control.Concurrent.STM as STM 304import qualified Control.Concurrent.STM.TQueue as TQueue 305import Control.Exception (Exception, bracket, bracket_, finally, mask, throwIO) 306import Control.Foldl (Fold(..), genericLength, handles, list, premap) 307import qualified Control.Foldl 308import qualified Control.Foldl.Text 309import Control.Monad (foldM, guard, liftM, msum, when, unless, (>=>), mfilter) 310import Control.Monad.IO.Class (MonadIO(..)) 311import Control.Monad.Managed (MonadManaged(..), managed, managed_, runManaged) 312#ifdef mingw32_HOST_OS 313import Data.Bits ((.&.)) 314#endif 315import Data.IORef (newIORef, readIORef, writeIORef) 316import qualified Data.List as List 317import Data.List.NonEmpty (NonEmpty(..)) 318import qualified Data.List.NonEmpty as NonEmpty 319import Data.Monoid ((<>)) 320import Data.Ord (comparing) 321import qualified Data.Set as Set 322import Data.Text (Text, pack, unpack) 323import Data.Time (NominalDiffTime, UTCTime, getCurrentTime) 324import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime) 325import Data.Traversable 326import qualified Data.Text as Text 327import qualified Data.Text.IO as Text 328import Data.Typeable (Typeable) 329import qualified Filesystem 330import Filesystem.Path.CurrentOS (FilePath, (</>)) 331import qualified Filesystem.Path.CurrentOS as Filesystem 332import GHC.IO.Exception (IOErrorType(UnsupportedOperation)) 333import Network.HostName (getHostName) 334import System.Clock (Clock(..), TimeSpec(..), getTime) 335import System.Environment ( 336 getArgs, 337#if __GLASGOW_HASKELL__ >= 710 338 setEnv, 339 unsetEnv, 340#endif 341#if __GLASGOW_HASKELL__ >= 708 342 lookupEnv, 343#endif 344 getEnvironment ) 345import qualified System.Directory 346import qualified System.Directory as Directory 347import System.Exit (ExitCode(..), exitWith) 348import System.IO (Handle, hClose) 349import qualified System.IO as IO 350import System.IO.Temp (withTempDirectory, withTempFile) 351import System.IO.Error 352 (catchIOError, ioeGetErrorType, isPermissionError, isDoesNotExistError) 353import qualified System.PosixCompat as PosixCompat 354import qualified System.Process as Process 355#ifdef mingw32_HOST_OS 356import qualified System.Win32 as Win32 357#else 358import System.Posix ( 359 openDirStream, 360 readDirStream, 361 closeDirStream, 362 touchFile ) 363import System.Posix.Files (createSymbolicLink) 364#endif 365import Prelude hiding (FilePath, lines) 366 367import Turtle.Pattern (Pattern, anyChar, chars, match, selfless, sepBy) 368import Turtle.Shell 369import Turtle.Format (Format, format, makeFormat, d, w, (%), fp) 370import Turtle.Internal (ignoreSIGPIPE) 371import Turtle.Line 372 373{-| Run a command using @execvp@, retrieving the exit code 374 375 The command inherits @stdout@ and @stderr@ for the current process 376-} 377proc 378 :: MonadIO io 379 => Text 380 -- ^ Command 381 -> [Text] 382 -- ^ Arguments 383 -> Shell Line 384 -- ^ Lines of standard input 385 -> io ExitCode 386 -- ^ Exit code 387proc cmd args = 388 system 389 ( (Process.proc (unpack cmd) (map unpack args)) 390 { Process.std_in = Process.CreatePipe 391 , Process.std_out = Process.Inherit 392 , Process.std_err = Process.Inherit 393 } ) 394 395{-| Run a command line using the shell, retrieving the exit code 396 397 This command is more powerful than `proc`, but highly vulnerable to code 398 injection if you template the command line with untrusted input 399 400 The command inherits @stdout@ and @stderr@ for the current process 401-} 402shell 403 :: MonadIO io 404 => Text 405 -- ^ Command line 406 -> Shell Line 407 -- ^ Lines of standard input 408 -> io ExitCode 409 -- ^ Exit code 410shell cmdLine = 411 system 412 ( (Process.shell (unpack cmdLine)) 413 { Process.std_in = Process.CreatePipe 414 , Process.std_out = Process.Inherit 415 , Process.std_err = Process.Inherit 416 } ) 417 418data ProcFailed = ProcFailed 419 { procCommand :: Text 420 , procArguments :: [Text] 421 , procExitCode :: ExitCode 422 } deriving (Show, Typeable) 423 424instance Exception ProcFailed 425 426{-| This function is identical to `proc` except this throws `ProcFailed` for 427 non-zero exit codes 428-} 429procs 430 :: MonadIO io 431 => Text 432 -- ^ Command 433 -> [Text] 434 -- ^ Arguments 435 -> Shell Line 436 -- ^ Lines of standard input 437 -> io () 438procs cmd args s = do 439 exitCode <- proc cmd args s 440 case exitCode of 441 ExitSuccess -> return () 442 _ -> liftIO (throwIO (ProcFailed cmd args exitCode)) 443 444data ShellFailed = ShellFailed 445 { shellCommandLine :: Text 446 , shellExitCode :: ExitCode 447 } deriving (Show, Typeable) 448 449instance Exception ShellFailed 450 451{-| This function is identical to `shell` except this throws `ShellFailed` for 452 non-zero exit codes 453-} 454shells 455 :: MonadIO io 456 => Text 457 -- ^ Command line 458 -> Shell Line 459 -- ^ Lines of standard input 460 -> io () 461 -- ^ Exit code 462shells cmdline s = do 463 exitCode <- shell cmdline s 464 case exitCode of 465 ExitSuccess -> return () 466 _ -> liftIO (throwIO (ShellFailed cmdline exitCode)) 467 468{-| Run a command using @execvp@, retrieving the exit code and stdout as a 469 non-lazy blob of Text 470 471 The command inherits @stderr@ for the current process 472-} 473procStrict 474 :: MonadIO io 475 => Text 476 -- ^ Command 477 -> [Text] 478 -- ^ Arguments 479 -> Shell Line 480 -- ^ Lines of standard input 481 -> io (ExitCode, Text) 482 -- ^ Exit code and stdout 483procStrict cmd args = 484 systemStrict (Process.proc (Text.unpack cmd) (map Text.unpack args)) 485 486{-| Run a command line using the shell, retrieving the exit code and stdout as a 487 non-lazy blob of Text 488 489 This command is more powerful than `proc`, but highly vulnerable to code 490 injection if you template the command line with untrusted input 491 492 The command inherits @stderr@ for the current process 493-} 494shellStrict 495 :: MonadIO io 496 => Text 497 -- ^ Command line 498 -> Shell Line 499 -- ^ Lines of standard input 500 -> io (ExitCode, Text) 501 -- ^ Exit code and stdout 502shellStrict cmdLine = systemStrict (Process.shell (Text.unpack cmdLine)) 503 504{-| Run a command using @execvp@, retrieving the exit code, stdout, and stderr 505 as a non-lazy blob of Text 506-} 507procStrictWithErr 508 :: MonadIO io 509 => Text 510 -- ^ Command 511 -> [Text] 512 -- ^ Arguments 513 -> Shell Line 514 -- ^ Lines of standard input 515 -> io (ExitCode, Text, Text) 516 -- ^ (Exit code, stdout, stderr) 517procStrictWithErr cmd args = 518 systemStrictWithErr (Process.proc (Text.unpack cmd) (map Text.unpack args)) 519 520{-| Run a command line using the shell, retrieving the exit code, stdout, and 521 stderr as a non-lazy blob of Text 522 523 This command is more powerful than `proc`, but highly vulnerable to code 524 injection if you template the command line with untrusted input 525-} 526shellStrictWithErr 527 :: MonadIO io 528 => Text 529 -- ^ Command line 530 -> Shell Line 531 -- ^ Lines of standard input 532 -> io (ExitCode, Text, Text) 533 -- ^ (Exit code, stdout, stderr) 534shellStrictWithErr cmdLine = 535 systemStrictWithErr (Process.shell (Text.unpack cmdLine)) 536 537-- | Halt an `Async` thread, re-raising any exceptions it might have thrown 538halt :: Async a -> IO () 539halt a = do 540 m <- Control.Concurrent.Async.poll a 541 case m of 542 Nothing -> Control.Concurrent.Async.cancel a 543 Just (Left e) -> throwIO e 544 Just (Right _) -> return () 545 546{-| `system` generalizes `shell` and `proc` by allowing you to supply your own 547 custom `CreateProcess`. This is for advanced users who feel comfortable 548 using the lower-level @process@ API 549-} 550system 551 :: MonadIO io 552 => Process.CreateProcess 553 -- ^ Command 554 -> Shell Line 555 -- ^ Lines of standard input 556 -> io ExitCode 557 -- ^ Exit code 558system p s = liftIO (do 559 let open = do 560 (m, Nothing, Nothing, ph) <- Process.createProcess p 561 case m of 562 Just hIn -> IO.hSetBuffering hIn IO.LineBuffering 563 _ -> return () 564 return (m, ph) 565 566 -- Prevent double close 567 mvar <- newMVar False 568 let close handle = do 569 modifyMVar_ mvar (\finalized -> do 570 unless finalized (ignoreSIGPIPE (hClose handle)) 571 return True ) 572 let close' (Just hIn, ph) = do 573 close hIn 574 Process.terminateProcess ph 575 close' (Nothing , ph) = do 576 Process.terminateProcess ph 577 578 let handle (Just hIn, ph) = do 579 let feedIn :: (forall a. IO a -> IO a) -> IO () 580 feedIn restore = 581 restore (ignoreSIGPIPE (outhandle hIn s)) `finally` close hIn 582 mask (\restore -> 583 withAsync (feedIn restore) (\a -> 584 restore (Process.waitForProcess ph) `finally` halt a) ) 585 handle (Nothing , ph) = do 586 Process.waitForProcess ph 587 588 bracket open close' handle ) 589 590 591{-| `systemStrict` generalizes `shellStrict` and `procStrict` by allowing you to 592 supply your own custom `CreateProcess`. This is for advanced users who feel 593 comfortable using the lower-level @process@ API 594-} 595systemStrict 596 :: MonadIO io 597 => Process.CreateProcess 598 -- ^ Command 599 -> Shell Line 600 -- ^ Lines of standard input 601 -> io (ExitCode, Text) 602 -- ^ Exit code and stdout 603systemStrict p s = liftIO (do 604 let p' = p 605 { Process.std_in = Process.CreatePipe 606 , Process.std_out = Process.CreatePipe 607 , Process.std_err = Process.Inherit 608 } 609 610 let open = do 611 (Just hIn, Just hOut, Nothing, ph) <- liftIO (Process.createProcess p') 612 IO.hSetBuffering hIn IO.LineBuffering 613 return (hIn, hOut, ph) 614 615 -- Prevent double close 616 mvar <- newMVar False 617 let close handle = do 618 modifyMVar_ mvar (\finalized -> do 619 unless finalized (ignoreSIGPIPE (hClose handle)) 620 return True ) 621 622 bracket open (\(hIn, _, ph) -> close hIn >> Process.terminateProcess ph) (\(hIn, hOut, ph) -> do 623 let feedIn :: (forall a. IO a -> IO a) -> IO () 624 feedIn restore = 625 restore (ignoreSIGPIPE (outhandle hIn s)) `finally` close hIn 626 627 concurrently 628 (mask (\restore -> 629 withAsync (feedIn restore) (\a -> 630 restore (liftIO (Process.waitForProcess ph)) `finally` halt a ) )) 631 (Text.hGetContents hOut) ) ) 632 633{-| `systemStrictWithErr` generalizes `shellStrictWithErr` and 634 `procStrictWithErr` by allowing you to supply your own custom 635 `CreateProcess`. This is for advanced users who feel comfortable using 636 the lower-level @process@ API 637-} 638systemStrictWithErr 639 :: MonadIO io 640 => Process.CreateProcess 641 -- ^ Command 642 -> Shell Line 643 -- ^ Lines of standard input 644 -> io (ExitCode, Text, Text) 645 -- ^ Exit code and stdout 646systemStrictWithErr p s = liftIO (do 647 let p' = p 648 { Process.std_in = Process.CreatePipe 649 , Process.std_out = Process.CreatePipe 650 , Process.std_err = Process.CreatePipe 651 } 652 653 let open = do 654 (Just hIn, Just hOut, Just hErr, ph) <- liftIO (Process.createProcess p') 655 IO.hSetBuffering hIn IO.LineBuffering 656 return (hIn, hOut, hErr, ph) 657 658 -- Prevent double close 659 mvar <- newMVar False 660 let close handle = do 661 modifyMVar_ mvar (\finalized -> do 662 unless finalized (ignoreSIGPIPE (hClose handle)) 663 return True ) 664 665 bracket open (\(hIn, _, _, ph) -> close hIn >> Process.terminateProcess ph) (\(hIn, hOut, hErr, ph) -> do 666 let feedIn :: (forall a. IO a -> IO a) -> IO () 667 feedIn restore = 668 restore (ignoreSIGPIPE (outhandle hIn s)) `finally` close hIn 669 670 runConcurrently $ (,,) 671 <$> Concurrently (mask (\restore -> 672 withAsync (feedIn restore) (\a -> 673 restore (liftIO (Process.waitForProcess ph)) `finally` halt a ) )) 674 <*> Concurrently (Text.hGetContents hOut) 675 <*> Concurrently (Text.hGetContents hErr) ) ) 676 677{-| Run a command using @execvp@, streaming @stdout@ as lines of `Text` 678 679 The command inherits @stderr@ for the current process 680-} 681inproc 682 :: Text 683 -- ^ Command 684 -> [Text] 685 -- ^ Arguments 686 -> Shell Line 687 -- ^ Lines of standard input 688 -> Shell Line 689 -- ^ Lines of standard output 690inproc cmd args = stream (Process.proc (unpack cmd) (map unpack args)) 691 692{-| Run a command line using the shell, streaming @stdout@ as lines of `Text` 693 694 This command is more powerful than `inproc`, but highly vulnerable to code 695 injection if you template the command line with untrusted input 696 697 The command inherits @stderr@ for the current process 698 699 Throws an `ExitCode` exception if the command returns a non-zero exit code 700-} 701inshell 702 :: Text 703 -- ^ Command line 704 -> Shell Line 705 -- ^ Lines of standard input 706 -> Shell Line 707 -- ^ Lines of standard output 708inshell cmd = stream (Process.shell (unpack cmd)) 709 710waitForProcessThrows :: Process.ProcessHandle -> IO () 711waitForProcessThrows ph = do 712 exitCode <- Process.waitForProcess ph 713 case exitCode of 714 ExitSuccess -> return () 715 ExitFailure _ -> Control.Exception.throwIO exitCode 716 717{-| `stream` generalizes `inproc` and `inshell` by allowing you to supply your 718 own custom `CreateProcess`. This is for advanced users who feel comfortable 719 using the lower-level @process@ API 720 721 Throws an `ExitCode` exception if the command returns a non-zero exit code 722-} 723stream 724 :: Process.CreateProcess 725 -- ^ Command 726 -> Shell Line 727 -- ^ Lines of standard input 728 -> Shell Line 729 -- ^ Lines of standard output 730stream p s = do 731 let p' = p 732 { Process.std_in = Process.CreatePipe 733 , Process.std_out = Process.CreatePipe 734 , Process.std_err = Process.Inherit 735 } 736 737 let open = do 738 (Just hIn, Just hOut, Nothing, ph) <- liftIO (Process.createProcess p') 739 IO.hSetBuffering hIn IO.LineBuffering 740 return (hIn, hOut, ph) 741 742 -- Prevent double close 743 mvar <- liftIO (newMVar False) 744 let close handle = do 745 modifyMVar_ mvar (\finalized -> do 746 unless finalized (ignoreSIGPIPE (hClose handle)) 747 return True ) 748 749 (hIn, hOut, ph) <- using (managed (bracket open (\(hIn, _, ph) -> close hIn >> Process.terminateProcess ph))) 750 let feedIn :: (forall a. IO a -> IO a) -> IO () 751 feedIn restore = restore (ignoreSIGPIPE (outhandle hIn s)) `finally` close hIn 752 753 a <- using 754 (managed (\k -> 755 mask (\restore -> withAsync (feedIn restore) (restore . k)))) 756 inhandle hOut <|> (liftIO (waitForProcessThrows ph *> halt a) *> empty) 757 758{-| `streamWithErr` generalizes `inprocWithErr` and `inshellWithErr` by allowing 759 you to supply your own custom `CreateProcess`. This is for advanced users 760 who feel comfortable using the lower-level @process@ API 761 762 Throws an `ExitCode` exception if the command returns a non-zero exit code 763-} 764streamWithErr 765 :: Process.CreateProcess 766 -- ^ Command 767 -> Shell Line 768 -- ^ Lines of standard input 769 -> Shell (Either Line Line) 770 -- ^ Lines of standard output 771streamWithErr p s = do 772 let p' = p 773 { Process.std_in = Process.CreatePipe 774 , Process.std_out = Process.CreatePipe 775 , Process.std_err = Process.CreatePipe 776 } 777 778 let open = do 779 (Just hIn, Just hOut, Just hErr, ph) <- liftIO (Process.createProcess p') 780 IO.hSetBuffering hIn IO.LineBuffering 781 return (hIn, hOut, hErr, ph) 782 783 -- Prevent double close 784 mvar <- liftIO (newMVar False) 785 let close handle = do 786 modifyMVar_ mvar (\finalized -> do 787 unless finalized (ignoreSIGPIPE (hClose handle)) 788 return True ) 789 790 (hIn, hOut, hErr, ph) <- using (managed (bracket open (\(hIn, _, _, ph) -> close hIn >> Process.terminateProcess ph))) 791 let feedIn :: (forall a. IO a -> IO a) -> IO () 792 feedIn restore = restore (ignoreSIGPIPE (outhandle hIn s)) `finally` close hIn 793 794 queue <- liftIO TQueue.newTQueueIO 795 let forwardOut :: (forall a. IO a -> IO a) -> IO () 796 forwardOut restore = 797 restore (sh (do 798 line <- inhandle hOut 799 liftIO (STM.atomically (TQueue.writeTQueue queue (Just (Right line)))) )) 800 `finally` STM.atomically (TQueue.writeTQueue queue Nothing) 801 let forwardErr :: (forall a. IO a -> IO a) -> IO () 802 forwardErr restore = 803 restore (sh (do 804 line <- inhandle hErr 805 liftIO (STM.atomically (TQueue.writeTQueue queue (Just (Left line)))) )) 806 `finally` STM.atomically (TQueue.writeTQueue queue Nothing) 807 let drain = Shell (\(FoldShell step begin done) -> do 808 let loop x numNothing 809 | numNothing < 2 = do 810 m <- STM.atomically (TQueue.readTQueue queue) 811 case m of 812 Nothing -> loop x $! numNothing + 1 813 Just e -> do 814 x' <- step x e 815 loop x' numNothing 816 | otherwise = return x 817 x1 <- loop begin (0 :: Int) 818 done x1 ) 819 820 a <- using 821 (managed (\k -> 822 mask (\restore -> withAsync (feedIn restore) (restore . k)) )) 823 b <- using 824 (managed (\k -> 825 mask (\restore -> withAsync (forwardOut restore) (restore . k)) )) 826 c <- using 827 (managed (\k -> 828 mask (\restore -> withAsync (forwardErr restore) (restore . k)) )) 829 let l `also` r = do 830 _ <- l <|> (r *> STM.retry) 831 _ <- r 832 return () 833 let waitAll = STM.atomically (waitSTM a `also` (waitSTM b `also` waitSTM c)) 834 drain <|> (liftIO (waitForProcessThrows ph *> waitAll) *> empty) 835 836{-| Run a command using the shell, streaming @stdout@ and @stderr@ as lines of 837 `Text`. Lines from @stdout@ are wrapped in `Right` and lines from @stderr@ 838 are wrapped in `Left`. 839 840 Throws an `ExitCode` exception if the command returns a non-zero exit code 841-} 842inprocWithErr 843 :: Text 844 -- ^ Command 845 -> [Text] 846 -- ^ Arguments 847 -> Shell Line 848 -- ^ Lines of standard input 849 -> Shell (Either Line Line) 850 -- ^ Lines of either standard output (`Right`) or standard error (`Left`) 851inprocWithErr cmd args = 852 streamWithErr (Process.proc (unpack cmd) (map unpack args)) 853 854{-| Run a command line using the shell, streaming @stdout@ and @stderr@ as lines 855 of `Text`. Lines from @stdout@ are wrapped in `Right` and lines from 856 @stderr@ are wrapped in `Left`. 857 858 This command is more powerful than `inprocWithErr`, but highly vulnerable to 859 code injection if you template the command line with untrusted input 860 861 Throws an `ExitCode` exception if the command returns a non-zero exit code 862-} 863inshellWithErr 864 :: Text 865 -- ^ Command line 866 -> Shell Line 867 -- ^ Lines of standard input 868 -> Shell (Either Line Line) 869 -- ^ Lines of either standard output (`Right`) or standard error (`Left`) 870inshellWithErr cmd = streamWithErr (Process.shell (unpack cmd)) 871 872{-| Print exactly one line to @stdout@ 873 874 To print more than one line see `Turtle.Format.printf`, which also supports 875 formatted output 876-} 877echo :: MonadIO io => Line -> io () 878echo line = liftIO (Text.putStrLn (lineToText line)) 879 880-- | Print exactly one line to @stderr@ 881err :: MonadIO io => Line -> io () 882err line = liftIO (Text.hPutStrLn IO.stderr (lineToText line)) 883 884{-| Read in a line from @stdin@ 885 886 Returns `Nothing` if at end of input 887-} 888readline :: MonadIO io => io (Maybe Line) 889readline = liftIO (do 890 eof <- IO.isEOF 891 if eof 892 then return Nothing 893 else fmap (Just . unsafeTextToLine . pack) getLine ) 894 895-- | Get command line arguments in a list 896arguments :: MonadIO io => io [Text] 897arguments = liftIO (fmap (map pack) getArgs) 898 899#if __GLASGOW_HASKELL__ >= 710 900{-| Set or modify an environment variable 901 902 Note: This will change the current environment for all of your program's 903 threads since this modifies the global state of the process 904-} 905export :: MonadIO io => Text -> Text -> io () 906export key val = liftIO (setEnv (unpack key) (unpack val)) 907 908-- | Delete an environment variable 909unset :: MonadIO io => Text -> io () 910unset key = liftIO (unsetEnv (unpack key)) 911#endif 912 913-- | Look up an environment variable 914need :: MonadIO io => Text -> io (Maybe Text) 915#if __GLASGOW_HASKELL__ >= 708 916need key = liftIO (fmap (fmap pack) (lookupEnv (unpack key))) 917#else 918need key = liftM (lookup key) env 919#endif 920 921-- | Retrieve all environment variables 922env :: MonadIO io => io [(Text, Text)] 923env = liftIO (fmap (fmap toTexts) getEnvironment) 924 where 925 toTexts (key, val) = (pack key, pack val) 926 927{-| Change the current directory 928 929 Note: This will change the current directory for all of your program's 930 threads since this modifies the global state of the process 931-} 932cd :: MonadIO io => FilePath -> io () 933cd path = liftIO (Filesystem.setWorkingDirectory path) 934 935{-| Change the current directory. Once the current 'Shell' is done, it returns 936back to the original directory. 937 938>>> :set -XOverloadedStrings 939>>> cd "/" 940>>> view (pushd "/tmp" >> pwd) 941FilePath "/tmp" 942>>> pwd 943FilePath "/" 944-} 945pushd :: MonadManaged managed => FilePath -> managed () 946pushd path = do 947 cwd <- pwd 948 using (managed_ (bracket_ (cd path) (cd cwd))) 949 950-- | Get the current directory 951pwd :: MonadIO io => io FilePath 952pwd = liftIO Filesystem.getWorkingDirectory 953 954-- | Get the home directory 955home :: MonadIO io => io FilePath 956home = liftIO Filesystem.getHomeDirectory 957 958-- | Get the path pointed to by a symlink 959readlink :: MonadIO io => FilePath -> io FilePath 960readlink = 961 fmap Filesystem.decodeString 962 . liftIO 963 . System.Directory.getSymbolicLinkTarget 964 . Filesystem.encodeString 965 966-- | Canonicalize a path 967realpath :: MonadIO io => FilePath -> io FilePath 968realpath path = liftIO (Filesystem.canonicalizePath path) 969 970#ifdef mingw32_HOST_OS 971fILE_ATTRIBUTE_REPARSE_POINT :: Win32.FileAttributeOrFlag 972fILE_ATTRIBUTE_REPARSE_POINT = 1024 973 974reparsePoint :: Win32.FileAttributeOrFlag -> Bool 975reparsePoint attr = fILE_ATTRIBUTE_REPARSE_POINT .&. attr /= 0 976#endif 977 978{-| Stream all immediate children of the given directory, excluding @\".\"@ and 979 @\"..\"@ 980-} 981ls :: FilePath -> Shell FilePath 982ls path = Shell (\(FoldShell step begin done) -> do 983 let path' = Filesystem.encodeString path 984 canRead <- fmap 985 Directory.readable 986 (Directory.getPermissions (deslash path')) 987#ifdef mingw32_HOST_OS 988 reparse <- fmap reparsePoint (Win32.getFileAttributes path') 989 if (canRead && not reparse) 990 then bracket 991 (Win32.findFirstFile (Filesystem.encodeString (path </> "*"))) 992 (\(h, _) -> Win32.findClose h) 993 (\(h, fdat) -> do 994 let loop x = do 995 file' <- Win32.getFindDataFileName fdat 996 let file = Filesystem.decodeString file' 997 x' <- if (file' /= "." && file' /= "..") 998 then step x (path </> file) 999 else return x 1000 more <- Win32.findNextFile h fdat 1001 if more then loop $! x' else done x' 1002 loop $! begin ) 1003 else done begin ) 1004#else 1005 if canRead 1006 then bracket (openDirStream path') closeDirStream (\dirp -> do 1007 let loop x = do 1008 file' <- readDirStream dirp 1009 case file' of 1010 "" -> done x 1011 _ -> do 1012 let file = Filesystem.decodeString file' 1013 x' <- if (file' /= "." && file' /= "..") 1014 then step x (path </> file) 1015 else return x 1016 loop $! x' 1017 loop $! begin ) 1018 else done begin ) 1019#endif 1020 1021{-| This is used to remove the trailing slash from a path, because 1022 `getPermissions` will fail if a path ends with a trailing slash 1023-} 1024deslash :: String -> String 1025deslash [] = [] 1026deslash (c0:cs0) = c0:go cs0 1027 where 1028 go [] = [] 1029 go ['\\'] = [] 1030 go (c:cs) = c:go cs 1031 1032-- | Stream all recursive descendents of the given directory 1033lstree :: FilePath -> Shell FilePath 1034lstree path = do 1035 child <- ls path 1036 isDir <- testdir child 1037 if isDir 1038 then return child <|> lstree child 1039 else return child 1040 1041 1042{- | Stream the recursive descendents of a given directory 1043 between a given minimum and maximum depth 1044-} 1045lsdepth :: Int -> Int -> FilePath -> Shell FilePath 1046lsdepth mn mx path = 1047 lsdepthHelper 1 mn mx path 1048 where 1049 lsdepthHelper :: Int -> Int -> Int -> FilePath -> Shell FilePath 1050 lsdepthHelper depth l u p = 1051 if depth > u 1052 then empty 1053 else do 1054 child <- ls p 1055 isDir <- testdir child 1056 if isDir 1057 then if depth >= l 1058 then return child <|> lsdepthHelper (depth + 1) l u child 1059 else lsdepthHelper (depth + 1) l u child 1060 else if depth >= l 1061 then return child 1062 else empty 1063 1064{-| Stream all recursive descendents of the given directory 1065 1066 This skips any directories that fail the supplied predicate 1067 1068> lstree = lsif (\_ -> return True) 1069-} 1070lsif :: (FilePath -> IO Bool) -> FilePath -> Shell FilePath 1071lsif predicate path = do 1072 child <- ls path 1073 isDir <- testdir child 1074 if isDir 1075 then do 1076 continue <- liftIO (predicate child) 1077 if continue 1078 then return child <|> lsif predicate child 1079 else return child 1080 else return child 1081 1082{-| Move a file or directory 1083 1084 Works if the two paths are on the same filesystem. 1085 If not, @mv@ will still work when dealing with a regular file, 1086 but the operation will not be atomic 1087-} 1088mv :: MonadIO io => FilePath -> FilePath -> io () 1089mv oldPath newPath = liftIO $ catchIOError (Filesystem.rename oldPath newPath) 1090 (\ioe -> if ioeGetErrorType ioe == UnsupportedOperation -- certainly EXDEV 1091 then do 1092 Filesystem.copyFile oldPath newPath 1093 Filesystem.removeFile oldPath 1094 else ioError ioe) 1095 1096{-| Create a directory 1097 1098 Fails if the directory is present 1099-} 1100mkdir :: MonadIO io => FilePath -> io () 1101mkdir path = liftIO (Filesystem.createDirectory False path) 1102 1103{-| Create a directory tree (equivalent to @mkdir -p@) 1104 1105 Does not fail if the directory is present 1106-} 1107mktree :: MonadIO io => FilePath -> io () 1108mktree path = liftIO (Filesystem.createTree path) 1109 1110-- | Copy a file 1111cp :: MonadIO io => FilePath -> FilePath -> io () 1112cp oldPath newPath = liftIO (Filesystem.copyFile oldPath newPath) 1113 1114#if !defined(mingw32_HOST_OS) 1115-- | Create a symlink from one @FilePath@ to another 1116symlink :: MonadIO io => FilePath -> FilePath -> io () 1117symlink a b = liftIO $ createSymbolicLink (fp2fp a) (fp2fp b) 1118 where 1119 fp2fp = unpack . format fp 1120 1121#endif 1122 1123{-| Returns `True` if the given `FilePath` is not a symbolic link 1124 1125 This comes in handy in conjunction with `lsif`: 1126 1127 > lsif isNotSymbolicLink 1128-} 1129isNotSymbolicLink :: MonadIO io => FilePath -> io Bool 1130isNotSymbolicLink = fmap (not . PosixCompat.isSymbolicLink) . lstat 1131 1132-- | Copy a directory tree and preserve symbolic links 1133cptree :: MonadIO io => FilePath -> FilePath -> io () 1134cptree oldTree newTree = sh (do 1135 oldPath <- lsif isNotSymbolicLink oldTree 1136 1137 -- The `system-filepath` library treats a path like "/tmp" as a file and not 1138 -- a directory and fails to strip it as a prefix from `/tmp/foo`. Adding 1139 -- `(</> "")` to the end of the path makes clear that the path is a 1140 -- directory 1141 Just suffix <- return (Filesystem.stripPrefix (oldTree </> "") oldPath) 1142 1143 let newPath = newTree </> suffix 1144 1145 isFile <- testfile oldPath 1146 1147 fileStatus <- lstat oldPath 1148 1149 if PosixCompat.isSymbolicLink fileStatus 1150 then do 1151 oldTarget <- liftIO (PosixCompat.readSymbolicLink (Filesystem.encodeString oldPath)) 1152 1153 mktree (Filesystem.directory newPath) 1154 1155 liftIO (PosixCompat.createSymbolicLink oldTarget (Filesystem.encodeString newPath)) 1156 else if isFile 1157 then do 1158 mktree (Filesystem.directory newPath) 1159 1160 cp oldPath newPath 1161 else do 1162 mktree newPath ) 1163 1164-- | Copy a directory tree and dereference symbolic links 1165cptreeL :: MonadIO io => FilePath -> FilePath -> io () 1166cptreeL oldTree newTree = sh (do 1167 oldPath <- lstree oldTree 1168 Just suffix <- return (Filesystem.stripPrefix (oldTree </> "") oldPath) 1169 let newPath = newTree </> suffix 1170 isFile <- testfile oldPath 1171 if isFile 1172 then mktree (Filesystem.directory newPath) >> cp oldPath newPath 1173 else mktree newPath ) 1174 1175 1176-- | Remove a file 1177rm :: MonadIO io => FilePath -> io () 1178rm path = liftIO (Filesystem.removeFile path) 1179 1180-- | Remove a directory 1181rmdir :: MonadIO io => FilePath -> io () 1182rmdir path = liftIO (Filesystem.removeDirectory path) 1183 1184{-| Remove a directory tree (equivalent to @rm -r@) 1185 1186 Use at your own risk 1187-} 1188rmtree :: MonadIO io => FilePath -> io () 1189rmtree path0 = liftIO (sh (loop path0)) 1190 where 1191 loop path = do 1192 linkstat <- lstat path 1193 let isLink = PosixCompat.isSymbolicLink linkstat 1194 isDir = PosixCompat.isDirectory linkstat 1195 if isLink 1196 then rm path 1197 else do 1198 if isDir 1199 then (do 1200 child <- ls path 1201 loop child ) <|> rmdir path 1202 else rm path 1203 1204-- | Check if a file exists 1205testfile :: MonadIO io => FilePath -> io Bool 1206testfile path = liftIO (Filesystem.isFile path) 1207 1208-- | Check if a directory exists 1209testdir :: MonadIO io => FilePath -> io Bool 1210testdir path = liftIO (Filesystem.isDirectory path) 1211 1212-- | Check if a path exists 1213testpath :: MonadIO io => FilePath -> io Bool 1214testpath path = do 1215 exists <- testfile path 1216 if exists 1217 then return exists 1218 else testdir path 1219 1220{-| Touch a file, updating the access and modification times to the current time 1221 1222 Creates an empty file if it does not exist 1223-} 1224touch :: MonadIO io => FilePath -> io () 1225touch file = do 1226 exists <- testfile file 1227 liftIO (if exists 1228#ifdef mingw32_HOST_OS 1229 then do 1230 handle <- Win32.createFile 1231 (Filesystem.encodeString file) 1232 Win32.gENERIC_WRITE 1233 Win32.fILE_SHARE_NONE 1234 Nothing 1235 Win32.oPEN_EXISTING 1236 Win32.fILE_ATTRIBUTE_NORMAL 1237 Nothing 1238 (creationTime, _, _) <- Win32.getFileTime handle 1239 systemTime <- Win32.getSystemTimeAsFileTime 1240 Win32.setFileTime handle creationTime systemTime systemTime 1241#else 1242 then touchFile (Filesystem.encodeString file) 1243#endif 1244 else output file empty ) 1245 1246{-| This type is the same as @"System.Directory".`System.Directory.Permissions`@ 1247 type except combining the `System.Directory.executable` and 1248 `System.Directory.searchable` fields into a single `executable` field for 1249 consistency with the Unix @chmod@. This simplification is still entirely 1250 consistent with the behavior of "System.Directory", which treats the two 1251 fields as interchangeable. 1252-} 1253data Permissions = Permissions 1254 { _readable :: Bool 1255 , _writable :: Bool 1256 , _executable :: Bool 1257 } deriving (Eq, Read, Ord, Show) 1258 1259{-| Under the hood, "System.Directory" does not distinguish between 1260 `System.Directory.executable` and `System.Directory.searchable`. They both 1261 translate to the same `System.Posix.ownerExecuteMode` permission. That 1262 means that we can always safely just set the `System.Directory.executable` 1263 field and safely leave the `System.Directory.searchable` field as `False` 1264 because the two fields are combined with (`||`) to determine whether to set 1265 the executable bit. 1266-} 1267toSystemDirectoryPermissions :: Permissions -> System.Directory.Permissions 1268toSystemDirectoryPermissions p = 1269 ( System.Directory.setOwnerReadable (_readable p) 1270 . System.Directory.setOwnerWritable (_writable p) 1271 . System.Directory.setOwnerExecutable (_executable p) 1272 ) System.Directory.emptyPermissions 1273 1274fromSystemDirectoryPermissions :: System.Directory.Permissions -> Permissions 1275fromSystemDirectoryPermissions p = Permissions 1276 { _readable = System.Directory.readable p 1277 , _writable = System.Directory.writable p 1278 , _executable = 1279 System.Directory.executable p || System.Directory.searchable p 1280 } 1281 1282{-| Update a file or directory's user permissions 1283 1284> chmod rwo "foo.txt" -- chmod u=rw foo.txt 1285> chmod executable "foo.txt" -- chmod u+x foo.txt 1286> chmod nonwritable "foo.txt" -- chmod u-w foo.txt 1287 1288 The meaning of each permission is: 1289 1290 * `readable` (@+r@ for short): For files, determines whether you can read 1291 from that file (such as with `input`). For directories, determines 1292 whether or not you can list the directory contents (such as with `ls`). 1293 Note: if a directory is not readable then `ls` will stream an empty list 1294 of contents 1295 1296 * `writable` (@+w@ for short): For files, determines whether you can write 1297 to that file (such as with `output`). For directories, determines whether 1298 you can create a new file underneath that directory. 1299 1300 * `executable` (@+x@ for short): For files, determines whether or not that 1301 file is executable (such as with `proc`). For directories, determines 1302 whether or not you can read or execute files underneath that directory 1303 (such as with `input` or `proc`) 1304-} 1305chmod 1306 :: MonadIO io 1307 => (Permissions -> Permissions) 1308 -- ^ Permissions update function 1309 -> FilePath 1310 -- ^ Path 1311 -> io Permissions 1312 -- ^ Updated permissions 1313chmod modifyPermissions path = liftIO (do 1314 let path' = deslash (Filesystem.encodeString path) 1315 permissions <- Directory.getPermissions path' 1316 let permissions' = fromSystemDirectoryPermissions permissions 1317 let permissions'' = modifyPermissions permissions' 1318 changed = permissions' /= permissions'' 1319 let permissions''' = toSystemDirectoryPermissions permissions'' 1320 when changed (Directory.setPermissions path' permissions''') 1321 return permissions'' ) 1322 1323-- | Get a file or directory's user permissions 1324getmod :: MonadIO io => FilePath -> io Permissions 1325getmod path = liftIO (do 1326 let path' = deslash (Filesystem.encodeString path) 1327 permissions <- Directory.getPermissions path' 1328 return (fromSystemDirectoryPermissions permissions)) 1329 1330-- | Set a file or directory's user permissions 1331setmod :: MonadIO io => Permissions -> FilePath -> io () 1332setmod permissions path = liftIO (do 1333 let path' = deslash (Filesystem.encodeString path) 1334 Directory.setPermissions path' (toSystemDirectoryPermissions permissions) ) 1335 1336-- | Copy a file or directory's permissions (analogous to @chmod --reference@) 1337copymod :: MonadIO io => FilePath -> FilePath -> io () 1338copymod sourcePath targetPath = liftIO (do 1339 let sourcePath' = deslash (Filesystem.encodeString sourcePath) 1340 targetPath' = deslash (Filesystem.encodeString targetPath) 1341 Directory.copyPermissions sourcePath' targetPath' ) 1342 1343-- | @+r@ 1344readable :: Permissions -> Permissions 1345readable p = p { _readable = True } 1346 1347-- | @-r@ 1348nonreadable :: Permissions -> Permissions 1349nonreadable p = p { _readable = False } 1350 1351-- | @+w@ 1352writable :: Permissions -> Permissions 1353writable p = p { _writable = True } 1354 1355-- | @-w@ 1356nonwritable :: Permissions -> Permissions 1357nonwritable p = p { _writable = False } 1358 1359-- | @+x@ 1360executable :: Permissions -> Permissions 1361executable p = p { _executable = True } 1362 1363-- | @-x@ 1364nonexecutable :: Permissions -> Permissions 1365nonexecutable p = p { _executable = False } 1366 1367-- | @-r -w -x@ 1368ooo :: Permissions -> Permissions 1369ooo _ = Permissions 1370 { _readable = False 1371 , _writable = False 1372 , _executable = False 1373 } 1374 1375-- | @+r -w -x@ 1376roo :: Permissions -> Permissions 1377roo = readable . ooo 1378 1379-- | @-r +w -x@ 1380owo :: Permissions -> Permissions 1381owo = writable . ooo 1382 1383-- | @-r -w +x@ 1384oox :: Permissions -> Permissions 1385oox = executable . ooo 1386 1387-- | @+r +w -x@ 1388rwo :: Permissions -> Permissions 1389rwo = readable . writable . ooo 1390 1391-- | @+r -w +x@ 1392rox :: Permissions -> Permissions 1393rox = readable . executable . ooo 1394 1395-- | @-r +w +x@ 1396owx :: Permissions -> Permissions 1397owx = writable . executable . ooo 1398 1399-- | @+r +w +x@ 1400rwx :: Permissions -> Permissions 1401rwx = readable . writable . executable . ooo 1402 1403{-| Time how long a command takes in monotonic wall clock time 1404 1405 Returns the duration alongside the return value 1406-} 1407time :: MonadIO io => io a -> io (a, NominalDiffTime) 1408time io = do 1409 TimeSpec seconds1 nanoseconds1 <- liftIO (getTime Monotonic) 1410 a <- io 1411 TimeSpec seconds2 nanoseconds2 <- liftIO (getTime Monotonic) 1412 let t = fromIntegral ( seconds2 - seconds1) 1413 + fromIntegral (nanoseconds2 - nanoseconds1) / 10^(9::Int) 1414 return (a, fromRational t) 1415 1416-- | Get the system's host name 1417hostname :: MonadIO io => io Text 1418hostname = liftIO (fmap Text.pack getHostName) 1419 1420-- | Show the full path of an executable file 1421which :: MonadIO io => FilePath -> io (Maybe FilePath) 1422which cmd = fold (whichAll cmd) Control.Foldl.head 1423 1424-- | Show all matching executables in PATH, not just the first 1425whichAll :: FilePath -> Shell FilePath 1426whichAll cmd = do 1427 Just paths <- need "PATH" 1428 path <- select (Filesystem.splitSearchPathString . Text.unpack $ paths) 1429 let path' = path </> cmd 1430 1431 True <- testfile path' 1432 1433 let handler :: IOError -> IO Bool 1434 handler e = 1435 if isPermissionError e || isDoesNotExistError e 1436 then return False 1437 else throwIO e 1438 1439 let getIsExecutable = fmap _executable (getmod path') 1440 isExecutable <- liftIO (getIsExecutable `catchIOError` handler) 1441 1442 guard isExecutable 1443 return path' 1444 1445{-| Sleep for the given duration 1446 1447 A numeric literal argument is interpreted as seconds. In other words, 1448 @(sleep 2.0)@ will sleep for two seconds. 1449-} 1450sleep :: MonadIO io => NominalDiffTime -> io () 1451sleep n = liftIO (threadDelay (truncate (n * 10^(6::Int)))) 1452 1453{-| Exit with the given exit code 1454 1455 An exit code of @0@ indicates success 1456-} 1457exit :: MonadIO io => ExitCode -> io a 1458exit code = liftIO (exitWith code) 1459 1460-- | Throw an exception using the provided `Text` message 1461die :: MonadIO io => Text -> io a 1462die txt = liftIO (throwIO (userError (unpack txt))) 1463 1464infixr 2 .||. 1465infixr 3 .&&. 1466 1467{-| Analogous to `&&` in Bash 1468 1469 Runs the second command only if the first one returns `ExitSuccess` 1470-} 1471(.&&.) :: Monad m => m ExitCode -> m ExitCode -> m ExitCode 1472cmd1 .&&. cmd2 = do 1473 r <- cmd1 1474 case r of 1475 ExitSuccess -> cmd2 1476 _ -> return r 1477 1478{-| Analogous to `||` in Bash 1479 1480 Run the second command only if the first one returns `ExitFailure` 1481-} 1482(.||.) :: Monad m => m ExitCode -> m ExitCode -> m ExitCode 1483cmd1 .||. cmd2 = do 1484 r <- cmd1 1485 case r of 1486 ExitFailure _ -> cmd2 1487 _ -> return r 1488 1489{-| Create a temporary directory underneath the given directory 1490 1491 Deletes the temporary directory when done 1492-} 1493mktempdir 1494 :: MonadManaged managed 1495 => FilePath 1496 -- ^ Parent directory 1497 -> Text 1498 -- ^ Directory name template 1499 -> managed FilePath 1500mktempdir parent prefix = using (do 1501 let parent' = Filesystem.encodeString parent 1502 let prefix' = unpack prefix 1503 dir' <- managed (withTempDirectory parent' prefix') 1504 return (Filesystem.decodeString dir')) 1505 1506{-| Create a temporary file underneath the given directory 1507 1508 Deletes the temporary file when done 1509 1510 Note that this provides the `Handle` of the file in order to avoid a 1511 potential race condition from the file being moved or deleted before you 1512 have a chance to open the file. The `mktempfile` function provides a 1513 simpler API if you don't need to worry about that possibility. 1514-} 1515mktemp 1516 :: MonadManaged managed 1517 => FilePath 1518 -- ^ Parent directory 1519 -> Text 1520 -- ^ File name template 1521 -> managed (FilePath, Handle) 1522mktemp parent prefix = using (do 1523 let parent' = Filesystem.encodeString parent 1524 let prefix' = unpack prefix 1525 (file', handle) <- managed (\k -> 1526 withTempFile parent' prefix' (\file' handle -> k (file', handle)) ) 1527 return (Filesystem.decodeString file', handle) ) 1528 1529{-| Create a temporary file underneath the given directory 1530 1531 Deletes the temporary file when done 1532-} 1533mktempfile 1534 :: MonadManaged managed 1535 => FilePath 1536 -- ^ Parent directory 1537 -> Text 1538 -- ^ File name template 1539 -> managed FilePath 1540mktempfile parent prefix = using (do 1541 let parent' = Filesystem.encodeString parent 1542 let prefix' = unpack prefix 1543 (file', handle) <- managed (\k -> 1544 withTempFile parent' prefix' (\file' handle -> k (file', handle)) ) 1545 liftIO (hClose handle) 1546 return (Filesystem.decodeString file') ) 1547 1548-- | Fork a thread, acquiring an `Async` value 1549fork :: MonadManaged managed => IO a -> managed (Async a) 1550fork io = using (managed (withAsync io)) 1551 1552-- | Wait for an `Async` action to complete 1553wait :: MonadIO io => Async a -> io a 1554wait a = liftIO (Control.Concurrent.Async.wait a) 1555 1556-- | Read lines of `Text` from standard input 1557stdin :: Shell Line 1558stdin = inhandle IO.stdin 1559 1560-- | Read lines of `Text` from a file 1561input :: FilePath -> Shell Line 1562input file = do 1563 handle <- using (readonly file) 1564 inhandle handle 1565 1566-- | Read lines of `Text` from a `Handle` 1567inhandle :: Handle -> Shell Line 1568inhandle handle = Shell (\(FoldShell step begin done) -> do 1569 let loop x = do 1570 eof <- IO.hIsEOF handle 1571 if eof 1572 then done x 1573 else do 1574 txt <- Text.hGetLine handle 1575 x' <- step x (unsafeTextToLine txt) 1576 loop $! x' 1577 loop $! begin ) 1578 1579-- | Stream lines of `Text` to standard output 1580stdout :: MonadIO io => Shell Line -> io () 1581stdout s = sh (do 1582 line <- s 1583 liftIO (echo line) ) 1584 1585-- | Stream lines of `Text` to a file 1586output :: MonadIO io => FilePath -> Shell Line -> io () 1587output file s = sh (do 1588 handle <- using (writeonly file) 1589 line <- s 1590 liftIO (Text.hPutStrLn handle (lineToText line)) ) 1591 1592-- | Stream lines of `Text` to a `Handle` 1593outhandle :: MonadIO io => Handle -> Shell Line -> io () 1594outhandle handle s = sh (do 1595 line <- s 1596 liftIO (Text.hPutStrLn handle (lineToText line)) ) 1597 1598-- | Stream lines of `Text` to append to a file 1599append :: MonadIO io => FilePath -> Shell Line -> io () 1600append file s = sh (do 1601 handle <- using (appendonly file) 1602 line <- s 1603 liftIO (Text.hPutStrLn handle (lineToText line)) ) 1604 1605-- | Stream lines of `Text` to standard error 1606stderr :: MonadIO io => Shell Line -> io () 1607stderr s = sh (do 1608 line <- s 1609 liftIO (err line) ) 1610 1611-- | Read in a stream's contents strictly 1612strict :: MonadIO io => Shell Line -> io Text 1613strict s = liftM linesToText (fold s list) 1614 1615-- | Acquire a `Managed` read-only `Handle` from a `FilePath` 1616readonly :: MonadManaged managed => FilePath -> managed Handle 1617readonly file = using (managed (Filesystem.withTextFile file IO.ReadMode)) 1618 1619-- | Acquire a `Managed` write-only `Handle` from a `FilePath` 1620writeonly :: MonadManaged managed => FilePath -> managed Handle 1621writeonly file = using (managed (Filesystem.withTextFile file IO.WriteMode)) 1622 1623-- | Acquire a `Managed` append-only `Handle` from a `FilePath` 1624appendonly :: MonadManaged managed => FilePath -> managed Handle 1625appendonly file = using (managed (Filesystem.withTextFile file IO.AppendMode)) 1626 1627-- | Combine the output of multiple `Shell`s, in order 1628cat :: [Shell a] -> Shell a 1629cat = msum 1630 1631grepWith :: (b -> Text) -> Pattern a -> Shell b -> Shell b 1632grepWith f pattern' = mfilter (not . null . match pattern' . f) 1633 1634-- | Keep all lines that match the given `Pattern` 1635grep :: Pattern a -> Shell Line -> Shell Line 1636grep = grepWith lineToText 1637 1638-- | Keep every `Text` element that matches the given `Pattern` 1639grepText :: Pattern a -> Shell Text -> Shell Text 1640grepText = grepWith id 1641 1642{-| Replace all occurrences of a `Pattern` with its `Text` result 1643 1644 `sed` performs substitution on a line-by-line basis, meaning that 1645 substitutions may not span multiple lines. Additionally, substitutions may 1646 occur multiple times within the same line, like the behavior of 1647 @s\/...\/...\/g@. 1648 1649 Warning: Do not use a `Pattern` that matches the empty string, since it will 1650 match an infinite number of times. `sed` tries to detect such `Pattern`s 1651 and `die` with an error message if they occur, but this detection is 1652 necessarily incomplete. 1653-} 1654sed :: Pattern Text -> Shell Line -> Shell Line 1655sed pattern' s = do 1656 when (matchesEmpty pattern') (die message) 1657 let pattern'' = fmap Text.concat 1658 (many (pattern' <|> fmap Text.singleton anyChar)) 1659 line <- s 1660 txt':_ <- return (match pattern'' (lineToText line)) 1661 select (textToLines txt') 1662 where 1663 message = "sed: the given pattern matches the empty string" 1664 matchesEmpty = not . null . flip match "" 1665 1666{-| Like `sed`, but the provided substitution must match the beginning of the 1667 line 1668-} 1669sedPrefix :: Pattern Text -> Shell Line -> Shell Line 1670sedPrefix pattern' s = do 1671 line <- s 1672 txt':_ <- return (match ((pattern' <> chars) <|> chars) (lineToText line)) 1673 select (textToLines txt') 1674 1675-- | Like `sed`, but the provided substitution must match the end of the line 1676sedSuffix :: Pattern Text -> Shell Line -> Shell Line 1677sedSuffix pattern' s = do 1678 line <- s 1679 txt':_ <- return (match ((chars <> pattern') <|> chars) (lineToText line)) 1680 select (textToLines txt') 1681 1682-- | Like `sed`, but the provided substitution must match the entire line 1683sedEntire :: Pattern Text -> Shell Line -> Shell Line 1684sedEntire pattern' s = do 1685 line <- s 1686 txt':_ <- return (match (pattern' <|> chars)(lineToText line)) 1687 select (textToLines txt') 1688 1689-- | Make a `Shell Text -> Shell Text` function work on `FilePath`s instead. 1690-- | Ignores any paths which cannot be decoded as valid `Text`. 1691onFiles :: (Shell Text -> Shell Text) -> Shell FilePath -> Shell FilePath 1692onFiles f = fmap Filesystem.fromText . f . getRights . fmap Filesystem.toText 1693 where 1694 getRights :: forall a. Shell (Either a Text) -> Shell Text 1695 getRights s = s >>= either (const empty) return 1696 1697 1698-- | Like `sed`, but operates in place on a `FilePath` (analogous to @sed -i@) 1699inplace :: MonadIO io => Pattern Text -> FilePath -> io () 1700inplace = update . sed 1701 1702-- | Like `sedPrefix`, but operates in place on a `FilePath` 1703inplacePrefix :: MonadIO io => Pattern Text -> FilePath -> io () 1704inplacePrefix = update . sedPrefix 1705 1706-- | Like `sedSuffix`, but operates in place on a `FilePath` 1707inplaceSuffix :: MonadIO io => Pattern Text -> FilePath -> io () 1708inplaceSuffix = update . sedSuffix 1709 1710-- | Like `sedEntire`, but operates in place on a `FilePath` 1711inplaceEntire :: MonadIO io => Pattern Text -> FilePath -> io () 1712inplaceEntire = update . sedEntire 1713 1714{-| Update a file in place using a `Shell` transformation 1715 1716 For example, this is used to implement the @inplace*@ family of utilities 1717-} 1718update :: MonadIO io => (Shell Line -> Shell Line) -> FilePath -> io () 1719update f file = liftIO (runManaged (do 1720 here <- pwd 1721 1722 (tmpfile, handle) <- mktemp here "turtle" 1723 1724 outhandle handle (f (input file)) 1725 1726 liftIO (hClose handle) 1727 1728 copymod file tmpfile 1729 1730 mv tmpfile file )) 1731 1732-- | Search a directory recursively for all files matching the given `Pattern` 1733find :: Pattern a -> FilePath -> Shell FilePath 1734find pattern' dir = do 1735 path <- lsif isNotSymlink dir 1736 Right txt <- return (Filesystem.toText path) 1737 _:_ <- return (match pattern' txt) 1738 return path 1739 where 1740 isNotSymlink :: FilePath -> IO Bool 1741 isNotSymlink file = do 1742 file_stat <- lstat file 1743 return (not (PosixCompat.isSymbolicLink file_stat)) 1744 1745-- | Filter a shell of FilePaths according to a given pattern 1746findtree :: Pattern a -> Shell FilePath -> Shell FilePath 1747findtree pat files = do 1748 path <- files 1749 Right txt <- return (Filesystem.toText path) 1750 _:_ <- return (match pat txt) 1751 return path 1752 1753{- | Check if a file was last modified after a given 1754 timestamp 1755-} 1756cmin :: MonadIO io => UTCTime -> FilePath -> io Bool 1757cmin t file = do 1758 status <- lstat file 1759 return (adapt status) 1760 where 1761 adapt x = posixSecondsToUTCTime (modificationTime x) > t 1762 1763{- | Check if a file was last modified before a given 1764 timestamp 1765-} 1766cmax :: MonadIO io => UTCTime -> FilePath -> io Bool 1767cmax t file = do 1768 status <- lstat file 1769 return (adapt status) 1770 where 1771 adapt x = posixSecondsToUTCTime (modificationTime x) < t 1772 1773-- | A Stream of @\"y\"@s 1774yes :: Shell Line 1775yes = fmap (\_ -> "y") endless 1776 1777-- | Number each element of a `Shell` (starting at 0) 1778nl :: Num n => Shell a -> Shell (n, a) 1779nl s = Shell _foldShell' 1780 where 1781 _foldShell' (FoldShell step begin done) = _foldShell s (FoldShell step' begin' done') 1782 where 1783 step' (x, n) a = do 1784 x' <- step x (n, a) 1785 let n' = n + 1 1786 n' `seq` return (x', n') 1787 begin' = (begin, 0) 1788 done' (x, _) = done x 1789 1790data ZipState a b = Empty | HasA a | HasAB a b | Done 1791 1792{-| Merge two `Shell`s together, element-wise 1793 1794 If one `Shell` is longer than the other, the excess elements are 1795 truncated 1796-} 1797paste :: Shell a -> Shell b -> Shell (a, b) 1798paste sA sB = Shell _foldShellAB 1799 where 1800 _foldShellAB (FoldShell stepAB beginAB doneAB) = do 1801 tvar <- STM.atomically (STM.newTVar Empty) 1802 1803 let begin = () 1804 1805 let stepA () a = STM.atomically (do 1806 x <- STM.readTVar tvar 1807 case x of 1808 Empty -> STM.writeTVar tvar (HasA a) 1809 Done -> return () 1810 _ -> STM.retry ) 1811 let doneA () = STM.atomically (do 1812 x <- STM.readTVar tvar 1813 case x of 1814 Empty -> STM.writeTVar tvar Done 1815 Done -> return () 1816 _ -> STM.retry ) 1817 let foldA = FoldShell stepA begin doneA 1818 1819 let stepB () b = STM.atomically (do 1820 x <- STM.readTVar tvar 1821 case x of 1822 HasA a -> STM.writeTVar tvar (HasAB a b) 1823 Done -> return () 1824 _ -> STM.retry ) 1825 let doneB () = STM.atomically (do 1826 x <- STM.readTVar tvar 1827 case x of 1828 HasA _ -> STM.writeTVar tvar Done 1829 Done -> return () 1830 _ -> STM.retry ) 1831 let foldB = FoldShell stepB begin doneB 1832 1833 withAsync (_foldShell sA foldA) (\asyncA -> do 1834 withAsync (_foldShell sB foldB) (\asyncB -> do 1835 let loop x = do 1836 y <- STM.atomically (do 1837 z <- STM.readTVar tvar 1838 case z of 1839 HasAB a b -> do 1840 STM.writeTVar tvar Empty 1841 return (Just (a, b)) 1842 Done -> return Nothing 1843 _ -> STM.retry ) 1844 case y of 1845 Nothing -> return x 1846 Just ab -> do 1847 x' <- stepAB x ab 1848 loop $! x' 1849 x' <- loop $! beginAB 1850 wait asyncA 1851 wait asyncB 1852 doneAB x' ) ) 1853 1854-- | A `Shell` that endlessly emits @()@ 1855endless :: Shell () 1856endless = Shell (\(FoldShell step begin _) -> do 1857 let loop x = do 1858 x' <- step x () 1859 loop $! x' 1860 loop $! begin ) 1861 1862{-| Limit a `Shell` to a fixed number of values 1863 1864 NOTE: This is not lazy and will still consume the entire input stream. 1865 There is no way to implement a lazy version of this utility. 1866-} 1867limit :: Int -> Shell a -> Shell a 1868limit n s = Shell (\(FoldShell step begin done) -> do 1869 ref <- newIORef 0 -- I feel so dirty 1870 let step' x a = do 1871 n' <- readIORef ref 1872 writeIORef ref (n' + 1) 1873 if n' < n then step x a else return x 1874 _foldShell s (FoldShell step' begin done) ) 1875 1876{-| Limit a `Shell` to values that satisfy the predicate 1877 1878 This terminates the stream on the first value that does not satisfy the 1879 predicate 1880-} 1881limitWhile :: (a -> Bool) -> Shell a -> Shell a 1882limitWhile predicate s = Shell (\(FoldShell step begin done) -> do 1883 ref <- newIORef True 1884 let step' x a = do 1885 b <- readIORef ref 1886 let b' = b && predicate a 1887 writeIORef ref b' 1888 if b' then step x a else return x 1889 _foldShell s (FoldShell step' begin done) ) 1890 1891{-| Cache a `Shell`'s output so that repeated runs of the script will reuse the 1892 result of previous runs. You must supply a `FilePath` where the cached 1893 result will be stored. 1894 1895 The stored result is only reused if the `Shell` successfully ran to 1896 completion without any exceptions. Note: on some platforms Ctrl-C will 1897 flush standard input and signal end of file before killing the program, 1898 which may trick the program into \"successfully\" completing. 1899-} 1900cache :: (Read a, Show a) => FilePath -> Shell a -> Shell a 1901cache file s = do 1902 let cached = do 1903 line <- input file 1904 case reads (Text.unpack (lineToText line)) of 1905 [(ma, "")] -> return ma 1906 _ -> 1907 die (format ("cache: Invalid data stored in "%w) file) 1908 exists <- testfile file 1909 mas <- fold (if exists then cached else empty) list 1910 case [ () | Nothing <- mas ] of 1911 _:_ -> select [ a | Just a <- mas ] 1912 _ -> do 1913 handle <- using (writeonly file) 1914 let justs = do 1915 a <- s 1916 liftIO (Text.hPutStrLn handle (Text.pack (show (Just a)))) 1917 return a 1918 let nothing = do 1919 let n = Nothing :: Maybe () 1920 liftIO (Text.hPutStrLn handle (Text.pack (show n))) 1921 empty 1922 justs <|> nothing 1923 1924{-| Run a list of IO actions in parallel using fork and wait. 1925 1926 1927>>> view (parallel [(sleep 3) >> date, date, date]) 19282016-12-01 17:22:10.83296 UTC 19292016-12-01 17:22:07.829876 UTC 19302016-12-01 17:22:07.829963 UTC 1931 1932-} 1933parallel :: [IO a] -> Shell a 1934parallel = traverse fork >=> select >=> wait 1935 1936-- | Split a line into chunks delimited by the given `Pattern` 1937cut :: Pattern a -> Text -> [Text] 1938cut pattern' txt = head (match (selfless chars `sepBy` pattern') txt) 1939-- This `head` should be safe ... in theory 1940 1941-- | Get the current time 1942date :: MonadIO io => io UTCTime 1943date = liftIO getCurrentTime 1944 1945-- | Get the time a file was last modified 1946datefile :: MonadIO io => FilePath -> io UTCTime 1947datefile path = liftIO (Filesystem.getModified path) 1948 1949-- | Get the size of a file or a directory 1950du :: MonadIO io => FilePath -> io Size 1951du path = liftIO (do 1952 isDir <- testdir path 1953 size <- do 1954 if isDir 1955 then do 1956 let sizes = do 1957 child <- lstree path 1958 True <- testfile child 1959 liftIO (Filesystem.getSize child) 1960 fold sizes Control.Foldl.sum 1961 else Filesystem.getSize path 1962 return (Size size) ) 1963 1964{-| An abstract file size 1965 1966 Specify the units you want by using an accessor like `kilobytes` 1967 1968 The `Num` instance for `Size` interprets numeric literals as bytes 1969-} 1970newtype Size = Size { _bytes :: Integer } deriving (Eq, Ord, Num) 1971 1972instance Show Size where 1973 show = show . _bytes 1974 1975{-| `Format` a `Size` using a human readable representation 1976 1977>>> format sz 42 1978"42 B" 1979>>> format sz 2309 1980"2.309 KB" 1981>>> format sz 949203 1982"949.203 KB" 1983>>> format sz 1600000000 1984"1.600 GB" 1985>>> format sz 999999999999999999 1986"999999.999 TB" 1987-} 1988sz :: Format r (Size -> r) 1989sz = makeFormat (\(Size numBytes) -> 1990 let (numKilobytes, remainingBytes ) = numBytes `quotRem` 1000 1991 (numMegabytes, remainingKilobytes) = numKilobytes `quotRem` 1000 1992 (numGigabytes, remainingMegabytes) = numMegabytes `quotRem` 1000 1993 (numTerabytes, remainingGigabytes) = numGigabytes `quotRem` 1000 1994 in if numKilobytes <= 0 1995 then format (d%" B" ) remainingBytes 1996 else if numMegabytes == 0 1997 then format (d%"."%d%" KB") remainingKilobytes remainingBytes 1998 else if numGigabytes == 0 1999 then format (d%"."%d%" MB") remainingMegabytes remainingKilobytes 2000 else if numTerabytes == 0 2001 then format (d%"."%d%" GB") remainingGigabytes remainingMegabytes 2002 else format (d%"."%d%" TB") numTerabytes remainingGigabytes ) 2003 2004{-| Construct a 'Size' from an integer in bytes 2005 2006>>> format sz (B 42) 2007"42 B" 2008-} 2009pattern B :: Integral n => n -> Size 2010pattern B { bytes } <- (fromInteger . _bytes -> bytes) 2011 where 2012 B = fromIntegral 2013{-# COMPLETE B #-} 2014 2015{-| Construct a 'Size' from an integer in kilobytes 2016 2017>>> format sz (KB 42) 2018"42.0 KB" 2019>>> let B n = KB 1 in n 20201000 2021-} 2022pattern KB :: Integral n => n -> Size 2023pattern KB { kilobytes } <- (\(B x) -> x `div` 1000 -> kilobytes) 2024 where 2025 KB = B . (* 1000) 2026{-# COMPLETE KB #-} 2027 2028{-| Construct a 'Size' from an integer in megabytes 2029 2030>>> format sz (MB 42) 2031"42.0 MB" 2032>>> let KB n = MB 1 in n 20331000 2034-} 2035pattern MB :: Integral n => n -> Size 2036pattern MB { megabytes } <- (\(KB x) -> x `div` 1000 -> megabytes) 2037 where 2038 MB = KB . (* 1000) 2039{-# COMPLETE MB #-} 2040 2041{-| Construct a 'Size' from an integer in gigabytes 2042 2043>>> format sz (GB 42) 2044"42.0 GB" 2045>>> let MB n = GB 1 in n 20461000 2047-} 2048pattern GB :: Integral n => n -> Size 2049pattern GB { gigabytes } <- (\(MB x) -> x `div` 1000 -> gigabytes) 2050 where 2051 GB = MB . (* 1000) 2052{-# COMPLETE GB #-} 2053 2054{-| Construct a 'Size' from an integer in terabytes 2055 2056>>> format sz (TB 42) 2057"42.0 TB" 2058>>> let GB n = TB 1 in n 20591000 2060-} 2061pattern TB :: Integral n => n -> Size 2062pattern TB { terabytes } <- (\(GB x) -> x `div` 1000 -> terabytes) 2063 where 2064 TB = GB . (* 1000) 2065{-# COMPLETE TB #-} 2066 2067{-| Construct a 'Size' from an integer in kibibytes 2068 2069>>> format sz (KiB 42) 2070"43.8 KB" 2071>>> let B n = KiB 1 in n 20721024 2073-} 2074pattern KiB :: Integral n => n -> Size 2075pattern KiB { kibibytes } <- (\(B x) -> x `div` 1024 -> kibibytes) 2076 where 2077 KiB = B . (* 1024) 2078{-# COMPLETE KiB #-} 2079 2080{-| Construct a 'Size' from an integer in mebibytes 2081 2082>>> format sz (MiB 42) 2083"44.40 MB" 2084>>> let KiB n = MiB 1 in n 20851024 2086-} 2087pattern MiB :: Integral n => n -> Size 2088pattern MiB { mebibytes } <- (\(KiB x) -> x `div` 1024 -> mebibytes) 2089 where 2090 MiB = KiB . (* 1024) 2091{-# COMPLETE MiB #-} 2092 2093{-| Construct a 'Size' from an integer in gibibytes 2094 2095>>> format sz (GiB 42) 2096"45.97 GB" 2097>>> let MiB n = GiB 1 in n 20981024 2099-} 2100pattern GiB :: Integral n => n -> Size 2101pattern GiB { gibibytes } <- (\(MiB x) -> x `div` 1024 -> gibibytes) 2102 where 2103 GiB = MiB . (* 1024) 2104{-# COMPLETE GiB #-} 2105 2106{-| Construct a 'Size' from an integer in tebibytes 2107 2108>>> format sz (TiB 42) 2109"46.179 TB" 2110>>> let GiB n = TiB 1 in n 21111024 2112-} 2113pattern TiB :: Integral n => n -> Size 2114pattern TiB { tebibytes } <- (\(GiB x) -> x `div` 1024 -> tebibytes) 2115 where 2116 TiB = GiB . (* 1024) 2117{-# COMPLETE TiB #-} 2118 2119-- | Extract a size in bytes 2120bytes :: Integral n => Size -> n 2121 2122-- | @1 kilobyte = 1000 bytes@ 2123kilobytes :: Integral n => Size -> n 2124 2125-- | @1 megabyte = 1000 kilobytes@ 2126megabytes :: Integral n => Size -> n 2127 2128-- | @1 gigabyte = 1000 megabytes@ 2129gigabytes :: Integral n => Size -> n 2130 2131-- | @1 terabyte = 1000 gigabytes@ 2132terabytes :: Integral n => Size -> n 2133 2134-- | @1 kibibyte = 1024 bytes@ 2135kibibytes :: Integral n => Size -> n 2136 2137-- | @1 mebibyte = 1024 kibibytes@ 2138mebibytes :: Integral n => Size -> n 2139 2140-- | @1 gibibyte = 1024 mebibytes@ 2141gibibytes :: Integral n => Size -> n 2142 2143-- | @1 tebibyte = 1024 gibibytes@ 2144tebibytes :: Integral n => Size -> n 2145 2146{-| Count the number of characters in the stream (like @wc -c@) 2147 2148 This uses the convention that the elements of the stream are implicitly 2149 ended by newlines that are one character wide 2150-} 2151countChars :: Integral n => Fold Line n 2152countChars = 2153 premap lineToText Control.Foldl.Text.length + 2154 charsPerNewline * countLines 2155 2156charsPerNewline :: Num a => a 2157#ifdef mingw32_HOST_OS 2158charsPerNewline = 2 2159#else 2160charsPerNewline = 1 2161#endif 2162 2163-- | Count the number of words in the stream (like @wc -w@) 2164countWords :: Integral n => Fold Line n 2165countWords = premap (Text.words . lineToText) (handles traverse genericLength) 2166 2167{-| Count the number of lines in the stream (like @wc -l@) 2168 2169 This uses the convention that each element of the stream represents one 2170 line 2171-} 2172countLines :: Integral n => Fold Line n 2173countLines = genericLength 2174 2175-- | Get the status of a file 2176stat :: MonadIO io => FilePath -> io PosixCompat.FileStatus 2177stat = liftIO . PosixCompat.getFileStatus . Filesystem.encodeString 2178 2179-- | Size of the file in bytes. Does not follow symlinks 2180fileSize :: PosixCompat.FileStatus -> Size 2181fileSize = fromIntegral . PosixCompat.fileSize 2182 2183-- | Time of last access 2184accessTime :: PosixCompat.FileStatus -> POSIXTime 2185accessTime = realToFrac . PosixCompat.accessTime 2186 2187-- | Time of last modification 2188modificationTime :: PosixCompat.FileStatus -> POSIXTime 2189modificationTime = realToFrac . PosixCompat.modificationTime 2190 2191-- | Time of last status change (i.e. owner, group, link count, mode, etc.) 2192statusChangeTime :: PosixCompat.FileStatus -> POSIXTime 2193statusChangeTime = realToFrac . PosixCompat.statusChangeTime 2194 2195-- | Get the status of a file, but don't follow symbolic links 2196lstat :: MonadIO io => FilePath -> io PosixCompat.FileStatus 2197lstat = liftIO . PosixCompat.getSymbolicLinkStatus . Filesystem.encodeString 2198 2199data WithHeader a 2200 = Header a 2201 -- ^ The first line with the header 2202 | Row a a 2203 -- ^ Every other line: 1st element is header, 2nd element is original row 2204 deriving (Show) 2205 2206data Pair a b = Pair !a !b 2207 2208header :: Shell a -> Shell (WithHeader a) 2209header (Shell k) = Shell k' 2210 where 2211 k' (FoldShell step begin done) = k (FoldShell step' begin' done') 2212 where 2213 step' (Pair x Nothing ) a = do 2214 x' <- step x (Header a) 2215 return (Pair x' (Just a)) 2216 step' (Pair x (Just a)) b = do 2217 x' <- step x (Row a b) 2218 return (Pair x' (Just a)) 2219 2220 begin' = Pair begin Nothing 2221 2222 done' (Pair x _) = done x 2223 2224-- | Returns the result of a 'Shell' that outputs a single line. 2225-- Note that if no lines / more than 1 line is produced by the Shell, this function will `die` with an error message. 2226-- 2227-- > main = do 2228-- > directory <- single (inshell "pwd" empty) 2229-- > print directory 2230single :: MonadIO io => Shell a -> io a 2231single s = do 2232 as <- fold s Control.Foldl.list 2233 case as of 2234 [a] -> return a 2235 _ -> do 2236 let msg = format ("single: expected 1 line of input but there were "%d%" lines of input") (length as) 2237 die msg 2238 2239-- | Filter adjacent duplicate elements: 2240-- 2241-- >>> view (uniq (select [1,1,2,1,3])) 2242-- 1 2243-- 2 2244-- 1 2245-- 3 2246uniq :: Eq a => Shell a -> Shell a 2247uniq = uniqOn id 2248 2249-- | Filter adjacent duplicates determined after applying the function to the element: 2250-- 2251-- >>> view (uniqOn fst (select [(1,'a'),(1,'b'),(2,'c'),(1,'d'),(3,'e')])) 2252-- (1,'a') 2253-- (2,'c') 2254-- (1,'d') 2255-- (3,'e') 2256uniqOn :: Eq b => (a -> b) -> Shell a -> Shell a 2257uniqOn f = uniqBy (\a a' -> f a == f a') 2258 2259-- | Filter adjacent duplicate elements determined via the given function: 2260-- 2261-- >>> view (uniqBy (==) (select [1,1,2,1,3])) 2262-- 1 2263-- 2 2264-- 1 2265-- 3 2266uniqBy :: (a -> a -> Bool) -> Shell a -> Shell a 2267uniqBy cmp s = Shell $ \(FoldShell step begin done) -> do 2268 let step' (x, Just a') a | cmp a a' = return (x, Just a) 2269 step' (x, _) a = (, Just a) <$> step x a 2270 begin' = (begin, Nothing) 2271 done' (x, _) = done x 2272 foldShell s (FoldShell step' begin' done') 2273 2274-- | Return a new `Shell` that discards duplicates from the input `Shell`: 2275-- 2276-- >>> view (nub (select [1, 1, 2, 3, 3, 4, 3])) 2277-- 1 2278-- 2 2279-- 3 2280-- 4 2281nub :: Ord a => Shell a -> Shell a 2282nub = nubOn id 2283 2284-- | Return a new `Shell` that discards duplicates determined via the given function from the input `Shell`: 2285-- 2286-- >>> view (nubOn id (select [1, 1, 2, 3, 3, 4, 3])) 2287-- 1 2288-- 2 2289-- 3 2290-- 4 2291nubOn :: Ord b => (a -> b) -> Shell a -> Shell a 2292nubOn f s = Shell $ \(FoldShell step begin done) -> do 2293 let step' (x, bs) a | Set.member (f a) bs = return (x, bs) 2294 | otherwise = (, Set.insert (f a) bs) <$> step x a 2295 begin' = (begin, Set.empty) 2296 done' (x, _) = done x 2297 foldShell s (FoldShell step' begin' done') 2298 2299-- | Return a list of the sorted elements of the given `Shell`, keeping duplicates: 2300-- 2301-- >>> sort (select [1,4,2,3,3,7]) 2302-- [1,2,3,3,4,7] 2303sort :: (Functor io, MonadIO io, Ord a) => Shell a -> io [a] 2304sort = sortOn id 2305 2306-- | Return a list of the elements of the given `Shell`, sorted after applying the given function and keeping duplicates: 2307-- 2308-- >>> sortOn id (select [1,4,2,3,3,7]) 2309-- [1,2,3,3,4,7] 2310sortOn :: (Functor io, MonadIO io, Ord b) => (a -> b) -> Shell a -> io [a] 2311sortOn f = sortBy (comparing f) 2312 2313-- | Return a list of the elements of the given `Shell`, sorted by the given function and keeping duplicates: 2314-- 2315-- >>> sortBy (comparing fst) (select [(1,'a'),(4,'b'),(2,'c'),(3,'d'),(3,'e'),(7,'f')]) 2316-- [(1,'a'),(2,'c'),(3,'d'),(3,'e'),(4,'b'),(7,'f')] 2317sortBy :: (Functor io, MonadIO io) => (a -> a -> Ordering) -> Shell a -> io [a] 2318sortBy f s = List.sortBy f <$> fold s list 2319 2320{-| Group an arbitrary stream of `Text` into newline-delimited `Line`s 2321 2322>>> stdout (toLines ("ABC" <|> "DEF" <|> "GHI") 2323ABCDEFGHI 2324>>> stdout (toLines empty) -- Note that this always emits at least 1 `Line` 2325 2326>>> stdout (toLines ("ABC\nDEF" <|> "" <|> "GHI\nJKL")) 2327ABC 2328DEFGHI 2329JKL 2330-} 2331toLines :: Shell Text -> Shell Line 2332toLines (Shell k) = Shell k' 2333 where 2334 k' (FoldShell step begin done) = 2335 k (FoldShell step' begin' done') 2336 where 2337 step' (Pair x prefix) text = do 2338 let suffix :| lines = Turtle.Line.textToLines text 2339 2340 let line = prefix <> suffix 2341 2342 let lines' = line :| lines 2343 2344 x' <- foldM step x (NonEmpty.init lines') 2345 2346 let prefix' = NonEmpty.last lines' 2347 2348 return (Pair x' prefix') 2349 2350 begin' = (Pair begin "") 2351 2352 done' (Pair x prefix) = do 2353 x' <- step x prefix 2354 done x' 2355