diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,11 @@ +Darcs 2.16.5, 20 Feb 2022 + + This release is to support newer dependencies, most importantly + GHC 9.0 and Cabal 3.6. + + It also includes a small number of refactors that help with moving + to those newer dependencies. + Darcs 2.16.4, 20 May 2021 This release is mostly to fix http://bugs.darcs.net/issue2674 which can diff --git a/darcs.cabal b/darcs.cabal --- a/darcs.cabal +++ b/darcs.cabal @@ -1,6 +1,6 @@ Cabal-Version: 2.4 Name: darcs -version: 2.16.4 +version: 2.16.5 License: GPL-2.0-or-later License-file: COPYING Author: David Roundy , @@ -131,8 +131,8 @@ -- ---------------------------------------------------------------------- custom-setup - setup-depends: base >= 4.10 && < 4.15, - Cabal >= 2.2 && < 3.3, + setup-depends: base >= 4.10 && < 4.16, + Cabal >= 2.4 && < 3.7, process >= 1.2.3.0 && < 1.7, filepath >= 1.4.1 && < 1.5.0.0, directory >= 1.2.7 && < 1.4 @@ -376,6 +376,7 @@ Darcs.Util.Progress Darcs.Util.Prompt Darcs.Util.Ratified + Darcs.Util.Regex Darcs.Util.Show Darcs.Util.SignalHandler Darcs.Util.Ssh @@ -393,7 +394,6 @@ c-sources: src/atomic_create.c src/maybe_relink.c src/umask.c - src/system_encoding.c -- see http://bugs.darcs.net/issue1037 cc-options: -D_REENTRANT @@ -409,17 +409,18 @@ System.Posix System.Posix.Files System.Posix.IO - cpp-options: -DWIN32 -DHAVE_MAPI + cpp-options: -DWIN32 c-sources: src/win32/send_email.c build-depends: Win32 >= 2.4.0 && < 2.7 else build-depends: unix >= 2.7.1.0 && < 2.8 - build-depends: base >= 4.10 && < 4.15, + build-depends: base >= 4.10 && < 4.16, stm >= 2.1 && < 2.6, binary >= 0.5 && < 0.11, containers >= 0.5.6.2 && < 0.7, - regex-compat-tdfa >= 0.95.1 && < 0.96, + regex-base >= 0.94.0.1 && < 0.94.1, + regex-tdfa >= 1.3.1.0 && < 1.3.2, regex-applicative >= 0.2 && < 0.4, mtl >= 2.2.1 && < 2.3, transformers >= 0.4.2.0 && < 0.6, @@ -428,8 +429,8 @@ html >= 1.0.1.2 && < 1.1, filepath >= 1.4.1 && < 1.5.0.0, haskeline >= 0.7.2 && < 0.9, - memory >= 0.14 && < 0.16, - cryptonite >= 0.24 && < 0.28, + memory >= 0.14 && < 0.17, + cryptonite >= 0.24 && < 0.30, base16-bytestring >= 0.1.1.7 && < 1.1, utf8-string >= 1 && < 1.1, vector >= 0.11 && < 0.13, @@ -576,7 +577,7 @@ text, directory, FindBin >= 0.0.5 && < 0.1, - QuickCheck >= 2.13 && < 2.14, + QuickCheck >= 2.13 && < 2.15, leancheck >= 0.9 && < 0.10, HUnit >= 1.3 && < 1.7, test-framework >= 0.8.1.1 && < 0.9, diff --git a/harness/Darcs/Test/Patch/Arbitrary/NamedPrim.hs b/harness/Darcs/Test/Patch/Arbitrary/NamedPrim.hs --- a/harness/Darcs/Test/Patch/Arbitrary/NamedPrim.hs +++ b/harness/Darcs/Test/Patch/Arbitrary/NamedPrim.hs @@ -3,7 +3,7 @@ import Prelude () import Darcs.Prelude -import Test.QuickCheck +import Test.QuickCheck ( arbitrarySizedNatural, suchThat, Gen ) import Test.QuickCheck.Gen ( chooseAny ) import Darcs.Patch.Prim.Named ( NamedPrim, namedPrim, PrimPatchId, unsafePrimPatchId ) diff --git a/release/distributed-context b/release/distributed-context --- a/release/distributed-context +++ b/release/distributed-context @@ -1,1 +1,1 @@ -Just "\nContext:\n\n\n[TAG 2.16.4\nBen Franksen **20210520120106\n Ignore-this: 6ad053de84a2b3fcd9dc62076e0fbbad24d8c25ef4a659a163cadc1832b39686aa41a2b7a12928df\n] \n" +Just "\nContext:\n\n[TAG 2.16.5\nGanesh Sittampalam **20220220083531\n Ignore-this: 51417cb5dd488dc0d962ffb051f63ee1\n] \n" diff --git a/src/Darcs/Patch/Match.hs b/src/Darcs/Patch/Match.hs --- a/src/Darcs/Patch/Match.hs +++ b/src/Darcs/Patch/Match.hs @@ -90,7 +90,7 @@ , Operator ( Infix, Prefix ) , buildExpressionParser ) -import Text.Regex ( mkRegex, matchRegex ) +import Darcs.Util.Regex ( mkRegex, matchRegex ) import Control.Exception ( Exception, throw ) import Data.Maybe ( isJust ) diff --git a/src/Darcs/Repository/Prefs.hs b/src/Darcs/Repository/Prefs.hs --- a/src/Darcs/Repository/Prefs.hs +++ b/src/Darcs/Repository/Prefs.hs @@ -30,7 +30,6 @@ , changePrefval , defPrefval , writeDefaultPrefs - , boringRegexps , isBoring , FileType(..) , filetypeFunction @@ -66,7 +65,6 @@ import System.IO ( stdout, stderr ) import System.Info ( os ) import System.Posix.Files ( getFileStatus, fileOwner ) -import Text.Regex ( Regex, mkRegex, matchRegex ) import Darcs.Repository.Cache ( Cache, mkCache, CacheType(..), CacheLoc(..), WritableOrNot(..) ) @@ -84,6 +82,7 @@ import Darcs.Util.Path ( AbsolutePath, ioAbsolute, toFilePath, getCurrentDirectory ) import Darcs.Util.Printer( hPutDocLn, text ) +import Darcs.Util.Regex ( Regex, mkRegex, matchRegex ) import Darcs.Util.URL ( isValidLocalPath ) import Darcs.Util.File ( osxCacheDir, xdgCacheDir, removeFileMayNotExist ) diff --git a/src/Darcs/Repository/State.hs b/src/Darcs/Repository/State.hs --- a/src/Darcs/Repository/State.hs +++ b/src/Darcs/Repository/State.hs @@ -42,10 +42,8 @@ import Control.Monad ( when, foldM, forM, void ) import Control.Monad.State ( StateT, runStateT, get, put, liftIO ) import Control.Exception ( catch, IOException ) -import Data.Maybe ( isJust ) import Data.Ord ( comparing ) import Data.List ( sortBy, union, delete ) -import Text.Regex( matchRegex ) import System.Directory( doesFileExist, doesDirectoryExist, renameFile ) import System.FilePath ( (<.>), () ) @@ -82,7 +80,7 @@ import Darcs.Repository.InternalTypes ( Repository, repoFormat, repoLocation ) import Darcs.Repository.Format(formatHas, RepoProperty(NoWorkingDir)) import qualified Darcs.Repository.Pending as Pending -import Darcs.Repository.Prefs ( filetypeFunction, boringRegexps ) +import Darcs.Repository.Prefs ( filetypeFunction, isBoring ) import Darcs.Repository.Diff ( treeDiff ) import Darcs.Repository.Inventory ( peekPristineHash, getValidHash ) import Darcs.Repository.Paths @@ -99,7 +97,7 @@ import Darcs.Util.Global ( debugMessage ) import Darcs.Util.Path ( AnchoredPath - , anchorPath + , realPath , filterPaths , inDarcsdir , parents @@ -174,14 +172,14 @@ -- to darcs. The result is usually applied to the full working state. restrictBoring :: Tree m -> IO (TreeFilter m) restrictBoring guide = do - boring <- boringRegexps - let boring' p | inDarcsdir p = False - boring' p = not $ any (\rx -> isJust $ matchRegex rx p') boring - where p' = anchorPath "" p + boring <- isBoring + let exclude p = inDarcsdir p || boring (realPath p) restrictTree :: FilterTree t m => t m -> t m - restrictTree = Tree.filter $ \p _ -> case find guide p of - Nothing -> boring' p - _ -> True + restrictTree = + Tree.filter $ \p _ -> + case find guide p of + Nothing -> not (exclude p) + _ -> True return (TreeFilter restrictTree) -- | Construct a Tree filter that removes any darcs metadata files the diff --git a/src/Darcs/UI/Commands/Send.hs b/src/Darcs/UI/Commands/Send.hs --- a/src/Darcs/UI/Commands/Send.hs +++ b/src/Darcs/UI/Commands/Send.hs @@ -15,20 +15,14 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP, OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} module Darcs.UI.Commands.Send ( send ) where import Darcs.Prelude import System.Directory ( renameFile ) -import System.Exit - ( exitSuccess -#ifndef HAVE_MAPI - , ExitCode ( ExitFailure ) - , exitWith -#endif - ) +import System.Exit ( exitSuccess ) import System.IO ( hClose ) import Control.Exception ( catch, IOException, onException ) import Control.Monad ( when, unless, forM_ ) @@ -105,11 +99,7 @@ , sendEmailDoc , generateEmail , editFile - , getSystemEncoding - , isUTF8Locale -#ifndef HAVE_MAPI - , haveSendmail -#endif + , checkDefaultSendmail ) import Darcs.Util.ByteString ( mmapFilePS, isAscii ) import qualified Data.ByteString.Char8 as BC (unpack) @@ -179,7 +169,8 @@ ^ O.headerFields ^ O.author ^ O.charset - ^ O.sendmail + ^ O.mail + ^ O.sendmailCmd ^ O.output ^ O.sign ^ O.dryRunXml @@ -203,6 +194,12 @@ sendCmd (_,o) opts [unfixedrepodir] = withRepository (useCache ? opts) $ RepoJob $ \(repository :: Repository rt p wR wU wR) -> do + when (O.mail ? opts && dryRun ? opts == O.NoDryRun) $ do + -- If --mail is used and the user has not provided a --sendmail-command + -- and we can detect that the system has no default way to send emails, + -- then we want to fail early i.e. before asking the user any questions. + sm_cmd <- getSendmailCmd opts + when (isNothing sm_cmd) checkDefaultSendmail case O.sendToContext ? opts of Just contextfile -> do wtds <- decideOnBehavior opts (Nothing :: Maybe (Repository rt p wR wU wR)) @@ -230,16 +227,6 @@ => Repository rt p wR wU wT -> [DarcsFlag] -> [WhatToDo] -> String -> PatchSet rt p Origin wX -> IO () sendToThem repo opts wtds their_name them = do -#ifndef HAVE_MAPI - when (fst (O.sendmail ? opts) && dryRun ? opts == O.NoDryRun) $ do - -- If --mail is used, check if the user has sendmail or - -- provided a --sendmail-cmd - sendmail <- haveSendmail - sm_cmd <- getSendmailCmd opts - when (not sendmail && sm_cmd == "") $ do - putInfo opts noWorkingSendmail - exitWith $ ExitFailure 1 -#endif us <- readRepo repo common :> us' <- return $ findCommonWithThem us them checkUnrelatedRepos (O.allowUnrelatedRepos ? opts) us them @@ -276,7 +263,7 @@ fname <- make_fname to_be_sent let outname = case getOutput opts fname of Just f -> Just f - Nothing | fst (O.sendmail ? opts) -> Nothing + Nothing | O.mail ? opts -> Nothing | not $ null [ p | Post p <- wtds] -> Nothing | otherwise -> Just (makeAbsoluteOrStd here fname) case outname of @@ -339,13 +326,7 @@ Nothing -> do warnCharset charsetCouldNotGuess return mailcharset - Just "utf-8" -> do - -- Check the locale encoding for consistency - encoding <- getSystemEncoding - debugMessage $ currentEncodingIs encoding - unless (isUTF8Locale encoding) $ - warnCharset charsetUtf8MailDiffLocale - return mailcharset + Just "utf-8" -> return mailcharset -- Trust other cases (us-ascii) Just _ -> return mailcharset @@ -359,8 +340,8 @@ sendmail = (do - sm_cmd <- getSendmailCmd opts let to = generateEmailToString thetargets + sm_cmd <- getSendmailCmd opts sendEmailDoc from to thesubject (getCc opts) sm_cmd contentAndBundle body putInfo opts (success to (getCc opts))) @@ -600,11 +581,6 @@ creatingPatch :: String -> Doc creatingPatch repodir = "Creating patch to" <+> quoted repodir <> "..." -#ifndef HAVE_MAPI -noWorkingSendmail :: Doc -noWorkingSendmail = "No working sendmail instance on your machine!" -#endif - nothingSendable :: Doc nothingSendable = "No recorded local changes to send!" @@ -625,12 +601,6 @@ charsetCouldNotGuess :: String charsetCouldNotGuess = "darcs could not guess the charset of your mail." - -currentEncodingIs :: String -> String -currentEncodingIs e = "Current locale encoding: " ++ e - -charsetUtf8MailDiffLocale :: String -charsetUtf8MailDiffLocale = "your mail is valid UTF-8 but your locale differs." aborted :: Doc aborted = "Aborted." diff --git a/src/Darcs/UI/Commands/ShowAuthors.hs b/src/Darcs/UI/Commands/ShowAuthors.hs --- a/src/Darcs/UI/Commands/ShowAuthors.hs +++ b/src/Darcs/UI/Commands/ShowAuthors.hs @@ -28,7 +28,6 @@ import System.IO.Error ( catchIOError ) import Text.ParserCombinators.Parsec hiding ( lower, count, Line ) import Text.ParserCombinators.Parsec.Error -import Text.Regex ( Regex, mkRegexWithOpts, matchRegex ) import Darcs.Prelude @@ -46,6 +45,7 @@ import Darcs.Util.Lock ( readTextFile ) import Darcs.Util.Printer ( Doc, text ) import Darcs.Util.Path ( AbsolutePath ) +import Darcs.Util.Regex ( Regex, mkRegexWithOpts, matchRegex ) data Spelling = Spelling String String [Regex] -- name, email, regexps type ParsedLine = Maybe Spelling -- Nothing for blank lines diff --git a/src/Darcs/UI/External.hs b/src/Darcs/UI/External.hs --- a/src/Darcs/UI/External.hs +++ b/src/Darcs/UI/External.hs @@ -4,7 +4,6 @@ ( sendEmail , generateEmail , sendEmailDoc - , resendEmail , signString , verifyPS , execDocPipe @@ -12,33 +11,43 @@ , pipeDocSSH , viewDoc , viewDocWith - , haveSendmail - , sendmailPath + , checkDefaultSendmail , diffProgram , darcsProgram , editText , editFile -- * Locales , setDarcsEncodings - , getSystemEncoding - , isUTF8Locale ) where import Darcs.Prelude -import Data.Maybe ( isJust, isNothing, maybeToList ) -import Control.Monad ( unless, when, filterM, liftM2, void ) +import Data.Maybe ( isJust ) +#ifndef WIN32 +import Data.Maybe ( isNothing, maybeToList ) +#endif +import Control.Monad ( unless, when, filterM, void ) +#ifndef WIN32 +import Control.Monad ( liftM2 ) +#endif import Control.Concurrent.MVar ( MVar ) import System.Exit ( ExitCode(..) ) import System.Environment ( getEnv , getExecutablePath ) -import System.IO ( hPutStr, hPutStrLn, hClose, - hIsTerminalDevice, stdout, stderr, Handle ) -import System.Directory ( doesFileExist, - findExecutable ) +import System.Directory ( doesFileExist, findExecutable ) +import System.IO + ( Handle + , hClose + , hIsTerminalDevice + , hPutStr + , stderr + , stdout + ) +#ifndef WIN32 import System.FilePath.Posix ( () ) +#endif import System.Process ( createProcess, proc, CreateProcess(..), runInteractiveProcess, waitForProcess, StdStream(..) ) import System.Process.Internals ( ProcessHandle ) @@ -49,19 +58,12 @@ , setLocaleEncoding ) #endif -import Foreign.C.String ( CString, peekCString ) - import Control.Concurrent ( forkIO, newEmptyMVar, putMVar, takeMVar ) -import Control.Exception - ( try, finally, catch, IOException ) +import Control.Exception ( IOException, finally, try ) import System.IO.Error ( ioeGetErrorType ) import GHC.IO.Exception ( IOErrorType(ResourceVanished) ) -import Data.Char ( toLower ) -import Text.Regex -#if defined (HAVE_MAPI) +#ifdef WIN32 import Foreign.C ( withCString ) -#endif -#ifdef HAVE_MAPI import Foreign.Ptr ( nullPtr ) import Darcs.Util.Lock ( canonFilename, writeDocBinFile ) #endif @@ -75,10 +77,8 @@ import Darcs.Util.Progress ( withoutProgress, debugMessage ) import Darcs.Util.ByteString (linesPS, unlinesPS) -import qualified Data.ByteString as B (ByteString, empty, null, readFile - ,hGetContents, writeFile, hPut, length - ,take, concat, drop, isPrefixOf, singleton, append) -import qualified Data.ByteString.Char8 as BC (unpack, pack) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC import Darcs.Util.Lock ( withTemp @@ -87,24 +87,42 @@ ) import Darcs.Util.Ssh ( getSSH, SSHCmd(..) ) import Darcs.Util.CommandLine ( parseCmd, addUrlencoded ) +#ifndef WIN32 +import Darcs.Util.English ( orClauses ) +#endif import Darcs.Util.Exception ( catchall ) import Darcs.Util.Exec ( execInteractive, exec, Redirect(..), withoutNonBlock ) import Darcs.Util.URL ( SshFilePath, sshUhost ) -import Darcs.Util.Printer ( Doc, Printers, hPutDocLnWith, hPutDoc, hPutDocLn, hPutDocWith, ($$), renderPS, - simplePrinters, - hPutDocCompr, - text, empty, packedString, vcat, renderString ) +import Darcs.Util.Printer + ( Doc + , Printers + , hPutDoc + , hPutDocCompr + , hPutDocLn + , hPutDocLnWith + , hPutDocWith + , packedString + , renderPS + , renderString + , simplePrinters + , text + ) import qualified Darcs.Util.Ratified as Ratified import Darcs.UI.Email ( formatHeader ) +#ifndef WIN32 sendmailPath :: IO String sendmailPath = do + let searchPath = [ "/usr/sbin", "/sbin", "/usr/lib" ] l <- filterM doesFileExist $ liftM2 () - [ "/usr/sbin", "/sbin", "/usr/lib" ] + searchPath [ "sendmail" ] ex <- findExecutable "sendmail" - when (isNothing ex && null l) $ fail "Cannot find the \"sendmail\" program." + when (isNothing ex && null l) $ + fail $ "Cannot find the 'sendmail' program in " ++ + orClauses ("your PATH" : searchPath) ++ "." return $ head $ maybeToList ex ++ l +#endif diffProgram :: IO String diffProgram = do @@ -144,7 +162,7 @@ (ssh, ssh_args) <- getSSH SSH pipeDocInternal (PipeToSsh compress) ssh (ssh_args ++ ("--":sshUhost remoteAddr:args)) input -sendEmail :: String -> String -> String -> String -> String -> String -> IO () +sendEmail :: String -> String -> String -> String -> Maybe String -> String -> IO () sendEmail f t s cc scmd body = sendEmailDoc f t s cc scmd Nothing (text body) @@ -168,8 +186,19 @@ = B.hPut h (B.append (formatHeader field value) newline) newline = B.singleton 10 -haveSendmail :: IO Bool -haveSendmail = (sendmailPath >> return True) `catch` (\(_ :: IOException) -> return False) +checkDefaultSendmail :: IO () +#ifndef WIN32 +checkDefaultSendmail = void sendmailPath +#else +-- FIXME find a way to detect if sending via MAPI would work +checkDefaultSendmail = return () +{- + TODO do we want a warning message like this one here? + hPutStr stderr + "Warning: Using MAPI for sending mail. This may hang indefinitely " ++ + "if not properly configured.\n" +-} +#endif -- | Send an email, optionally containing a patch bundle -- (more precisely, its description and the bundle itself) @@ -178,35 +207,16 @@ -> String -- ^ to -> String -- ^ subject -> String -- ^ cc - -> String -- ^ send command + -> Maybe String -- ^ send command -> Maybe (Doc, Doc) -- ^ (content,bundle) -> Doc -- ^ body -> IO () sendEmailDoc _ "" _ "" _ _ _ = return () sendEmailDoc f "" s cc scmd mbundle body = sendEmailDoc f cc s "" scmd mbundle body -sendEmailDoc f t s cc scmd mbundle body = do - use_sendmail <- haveSendmail - if use_sendmail || scmd /= "" then - withOpenTemp $ \(h,fn) -> do - generateEmail h f t s cc body - hClose h - withOpenTemp $ \(hat,at) -> do - ftable' <- case mbundle of - Just (content,bundle) -> do - hPutDocLn hat bundle - return [ ('b', renderString content) , ('a', at) ] - Nothing -> - return [ ('b', renderString body) ] - hClose hat - let ftable = [ ('t',addressOnly t),('c',cc),('f',f),('s',s) ] ++ ftable' - r <- execSendmail ftable scmd fn - when (r /= ExitSuccess) $ fail ("failed to send mail to: " - ++ t ++ cc_list cc - ++ "\nPerhaps sendmail is not configured.") -#ifdef HAVE_MAPI - else do - r <- withCString t $ \tp -> +#ifdef WIN32 +sendEmailDoc f t s cc Nothing _mbundle body = do + r <- withCString t $ \tp -> withCString f $ \fp -> withCString cc $ \ccp -> withCString s $ \sp -> @@ -217,71 +227,53 @@ cfn <- canonFilename fn withCString cfn $ \pcfn -> c_send_email fp tp ccp sp nullPtr pcfn - when (r /= 0) $ fail ("failed to send mail to: " ++ t) -#else - else fail "no mail facility (sendmail or mapi) located at configure time!" + when (r /= 0) $ do + fail $ "Failed to send mail via MAPI to: " ++ recipients t cc #endif +sendEmailDoc f t s cc scmd mbundle body = + withOpenTemp $ \(h,fn) -> do + generateEmail h f t s cc body + hClose h + withOpenTemp $ \(hat,at) -> do + ftable' <- case mbundle of + Just (content,bundle) -> do + hPutDocLn hat bundle + return [ ('b', renderString content) , ('a', at) ] + Nothing -> + return [ ('b', renderString body) ] + hClose hat + let ftable = [ ('t',addressOnly t),('c',cc),('f',f),('s',s) ] ++ ftable' + r <- execSendmail ftable scmd fn + when (r /= ExitSuccess) $ + fail ("Failed to send mail to: " ++ recipients t cc) where addressOnly a = case dropWhile (/= '<') a of ('<':a2) -> takeWhile (/= '>') a2 _ -> a - cc_list [] = [] - cc_list c = " and cc'ed " ++ c +recipients :: String -> String -> String +recipients to "" = to +recipients to cc = to ++ " and cc'ed " ++ cc -resendEmail :: String -> String -> B.ByteString -> IO () -resendEmail "" _ _ = return () -resendEmail t scmd body = do - use_sendmail <- haveSendmail - if use_sendmail || scmd /= "" - then - withOpenTemp $ \(h,fn) -> do - hPutStrLn h $ "To: "++ t - hPutStrLn h $ find_from (linesPS body) - hPutStrLn h $ find_subject (linesPS body) - hPutDocLn h $ fixit $ linesPS body - hClose h - let ftable = [('t',t)] - r <- execSendmail ftable scmd fn - when (r /= ExitSuccess) $ fail ("failed to send mail to: " ++ t) - else -#ifdef HAVE_MAPI - fail "Don't know how to resend email with MAPI" +execSendmail :: [(Char,String)] -> Maybe String -> String -> IO ExitCode +#ifdef WIN32 +execSendmail _ Nothing _ = error "impossible" #else - fail "no mail facility (sendmail or mapi) located at configure time (use the sendmail-command option)!" +execSendmail _ Nothing fn = do + scmd <- sendmailPath + exec scmd ["-i", "-t"] (File fn, Null, AsIs) #endif - where br = BC.pack "\r" - darcsurl = BC.pack "DarcsURL:" - content = BC.pack "Content-" - from_start = BC.pack "From:" - subject_start = BC.pack "Subject:" - fixit (l:ls) - | B.null l = packedString B.empty $$ vcat (map packedString ls) - | l == br = packedString B.empty $$ vcat (map packedString ls) - | B.take 9 l == darcsurl || B.take 8 l == content - = packedString l $$ fixit ls - | otherwise = fixit ls - fixit [] = empty - find_from (l:ls) | B.take 5 l == from_start = BC.unpack l - | otherwise = find_from ls - find_from [] = "From: unknown" - find_subject (l:ls) | B.take 8 l == subject_start = BC.unpack l - | otherwise = find_subject ls - find_subject [] = "Subject: (no subject)" - -execSendmail :: [(Char,String)] -> String -> String -> IO ExitCode -execSendmail ftable scmd fn = - if scmd == "" then do - cmd <- sendmailPath - exec cmd ["-i", "-t"] (File fn, Null, AsIs) - else case parseCmd (addUrlencoded ftable) scmd of - Right (arg0:opts, wantstdin) -> - do let stdin = if wantstdin then File fn else Null - exec arg0 opts (stdin, Null, AsIs) - Left e -> fail $ "failed to send mail, invalid sendmail-command: "++show e - _ -> fail "failed to send mail, invalid sendmail-command" +execSendmail ftable (Just scmd) fn = + case parseCmd (addUrlencoded ftable) scmd of + Right (arg0:opts, wantstdin) -> + let stdin = if wantstdin then File fn else Null + in exec arg0 opts (stdin, Null, AsIs) + Right ([], _) -> + fail $ "Invalid sendmail-command "++show scmd + Left e -> + fail $ "Invalid sendmail-command "++show scmd++"\n"++show e -#ifdef HAVE_MAPI +#ifdef WIN32 foreign import ccall "win32/send_email.h send_email" c_send_email :: CString -> {- sender -} CString -> {- recipient -} @@ -370,7 +362,7 @@ fix_line x | B.length x < 3 = x | BC.pack "- -" `B.isPrefixOf` x = B.drop 2 x | otherwise = x -#if defined(WIN32) +#ifdef WIN32 fix_sep c | c=='/' = '\\' | otherwise = c fix_path p = map fix_sep p #else @@ -550,47 +542,3 @@ setForeignEncoding e setLocaleEncoding e #endif - --- The following functions are copied from the encoding package (BSD3 --- licence, by Henning Günther). - --- | @getSystemEncoding@ fetches the current encoding from locale -foreign import ccall "system_encoding.h get_system_encoding" - get_system_encoding :: IO CString - - -getSystemEncoding :: IO String -getSystemEncoding = do - enc <- get_system_encoding - peekCString enc - - --- | @isUTF8@ checks if an encoding is UTF-8 (or ascii, since it is a --- subset of UTF-8). -isUTF8Locale :: String -> Bool -isUTF8Locale codeName = case normalizeEncoding codeName of - -- ASCII - "ascii" -> True - "646" -> True - "ansi_x3_4_1968" -> True - "ansi_x3.4_1986" -> True - "cp367" -> True - "csascii" -> True - "ibm367" -> True - "iso646_us" -> True - "iso_646.irv_1991" -> True - "iso_ir_6" -> True - "us" -> True - "us_ascii" -> True - -- UTF-8 - "utf_8" -> True - "u8" -> True - "utf" -> True - "utf8" -> True - "utf8_ucs2" -> True - "utf8_ucs4" -> True - -- Everything else - _ -> False - where - normalizeEncoding s = map toLower $ subRegex sep s "_" - sep = mkRegex "[^0-9A-Za-z]+" diff --git a/src/Darcs/UI/Flags.hs b/src/Darcs/UI/Flags.hs --- a/src/Darcs/UI/Flags.hs +++ b/src/Darcs/UI/Flags.hs @@ -454,10 +454,11 @@ -- This flag is present if darcs was invoked with @--sendmail-command=COMMAND@ -- Alternatively the user can set @$S@@ENDMAIL@ which will be used as a -- fallback if present. -getSendmailCmd :: Config -> IO String -getSendmailCmd fs = case parseFlags O.sendmailCmd fs of - Just cmd -> return cmd - Nothing -> fmap (maybe "" id) $ lookupEnv "SENDMAIL" +getSendmailCmd :: Config -> IO (Maybe String) +getSendmailCmd fs = + case parseFlags O.sendmailCmd fs of + Nothing -> lookupEnv "SENDMAIL" + justcmd -> return justcmd -- | Accessor for output option getOutput :: Config -> FilePath -> Maybe AbsolutePathOrStd diff --git a/src/Darcs/UI/Options/All.hs b/src/Darcs/UI/Options/All.hs --- a/src/Darcs/UI/Options/All.hs +++ b/src/Darcs/UI/Options/All.hs @@ -140,7 +140,7 @@ , HeaderFields (..) , headerFields , sendToContext - , sendmail + , mail , sendmailCmd , charset , editDescription @@ -900,20 +900,6 @@ where arg (F.Context s) = Just s arg _ = Nothing --- TODO: do something about the nonsensical case (False, Just s) --- --- Some of the tests actually do this (pass --sendmail-command without --- passing --mail) and it's unclear if it's deliberate or just a historical --- accident after the issue2204 changes. We should untangle that and --- perhaps turn this into a single option with an optional argument. --- The other question to resolve is the interaction with the 'output' --- options to darcs send. -sendmailIso :: Iso (Bool -> Maybe String -> a) ((Bool, Maybe String) -> a) -sendmailIso = Iso uncurry curry - -sendmail :: PrimDarcsOption (Bool, Maybe String) -sendmail = imap sendmailIso $ mail ^ sendmailCmd - mail :: PrimDarcsOption Bool mail = singleNoArg [] ["mail"] F.Mail "send patch using sendmail" @@ -1005,7 +991,7 @@ , RawNoArg [] ["skip-conflicts"] F.SkipConflicts Nothing "filter out any patches that would create conflicts" ] --- Technically not an isomorphism, see 'sendmailIso'. +-- Technically not an isomorphism. externalMerge :: PrimDarcsOption ExternalMerge externalMerge = imap (Iso fw bw) $ singleStrArg [] ["external-merge"] F.ExternalMerge arg "COMMAND" "use external tool to merge conflicts" diff --git a/src/Darcs/UI/SelectChanges.hs b/src/Darcs/UI/SelectChanges.hs --- a/src/Darcs/UI/SelectChanges.hs +++ b/src/Darcs/UI/SelectChanges.hs @@ -346,7 +346,11 @@ -- after selecting with a splitter, the results may not be canonical canonizeAfterSplitter :: (FL p :> FL p) wA wB -> (FL p :> FL p) wA wB canonizeAfterSplitter (x :> y) = - let canonizeIfNeeded = maybe id canonizeSplit mspl + let + canonizeIfNeeded = + case mspl of + Just s -> canonizeSplit s + Nothing -> id in canonizeIfNeeded x :> canonizeIfNeeded y -- retrieve the results of patch selection diff --git a/src/Darcs/Util/Regex.hs b/src/Darcs/Util/Regex.hs new file mode 100644 --- /dev/null +++ b/src/Darcs/Util/Regex.hs @@ -0,0 +1,54 @@ +-- | This module is a subset of the defunct regex-compat-tdfa. +module Darcs.Util.Regex + ( Regex + , mkRegex + , mkRegexWithOpts + , matchRegex + ) where + +import Darcs.Prelude + +import Text.Regex.Base + ( RegexContext(matchM) + , RegexMaker(makeRegexOpts) + , defaultCompOpt + , defaultExecOpt + ) +import Text.Regex.TDFA (Regex, caseSensitive, multiline, newSyntax) + +-- | Makes a regular expression with the default options (multi-line, +-- case-sensitive). The syntax of regular expressions is +-- otherwise that of @egrep@ (i.e. POSIX \"extended\" regular +-- expressions). +mkRegex :: String -> Regex +mkRegex s = makeRegexOpts opt defaultExecOpt s + where + opt = defaultCompOpt {newSyntax = True, multiline = True} + +-- | Makes a regular expression, where the multi-line and +-- case-sensitive options can be changed from the default settings. +mkRegexWithOpts + :: String -- ^ The regular expression to compile + -> Bool -- ^ 'True' @\<=>@ @\'^\'@ and @\'$\'@ match the beginning and + -- end of individual lines respectively, and @\'.\'@ does /not/ + -- match the newline character. + -> Bool -- ^ 'True' @\<=>@ matching is case-sensitive + -> Regex -- ^ Returns: the compiled regular expression +mkRegexWithOpts s single_line case_sensitive + = let opt = defaultCompOpt + { multiline = (if single_line then True else False) + , caseSensitive = (if case_sensitive then True else False) + , newSyntax = True } + in makeRegexOpts opt defaultExecOpt s + +-- | Match a regular expression against a string +matchRegex :: + Regex -- ^ The regular expression + -> String -- ^ The string to match against + -> Maybe [String] -- ^ Returns: @'Just' strs@ if the match succeeded + -- (and @strs@ is the list of subexpression matches), + -- or 'Nothing' otherwise. +matchRegex p str = fmap go (matchM p str) + where + go :: (String, String, String, [String]) -> [String] + go (_, _, _, ss) = ss diff --git a/src/system_encoding.c b/src/system_encoding.c deleted file mode 100644 --- a/src/system_encoding.c +++ /dev/null @@ -1,10 +0,0 @@ -#include "system_encoding.h" - -char* get_system_encoding() { -#ifdef WIN32 - return "utf8"; -#else - setlocale(LC_ALL,""); - return nl_langinfo(CODESET); -#endif -} diff --git a/src/system_encoding.h b/src/system_encoding.h deleted file mode 100644 --- a/src/system_encoding.h +++ /dev/null @@ -1,11 +0,0 @@ -#ifndef __SYSTEM_ENCODING__ -#define __SYSTEM_ENCODING__ - -#ifndef WIN32 -#include -#include -#endif - -char* get_system_encoding(); - -#endif diff --git a/tests/issue1344_abort_early_cant_send.sh b/tests/issue1344_abort_early_cant_send.sh --- a/tests/issue1344_abort_early_cant_send.sh +++ b/tests/issue1344_abort_early_cant_send.sh @@ -26,8 +26,9 @@ . ./lib -# The mail sending code on Windows uses the MAPI API unconditionally -# so this test fails. +# The mail sending code on Windows uses the MAPI API if there is no +# sendmail-command configured using either option or environment +# variable. # If it's possible to discover in advance whether mail sending would work, # the code and this test could be improved to do that. abort_windows @@ -66,6 +67,7 @@ darcs send --author=me -a --to=random@random -O ../temp2 darcs send --author=me -a --to=random@random -o test.patch ../temp2 # Otherwise, fail early -(darcs send --mail --author=me -a --to=random@random ../temp2 || true) | grep "No working sendmail" +not darcs send --mail --author=me -a --to=random@random ../temp2 2>log +grep "Cannot find the 'sendmail' program" log cd .. diff --git a/tests/network/external.sh b/tests/network/external.sh --- a/tests/network/external.sh +++ b/tests/network/external.sh @@ -5,33 +5,36 @@ . lib rm -rf temp1 +rm -f fakessh -touch_fakessh='./touch-fakessh' -if echo $OS | grep -i windows; then - touch_fakessh="touch_fakessh.bat" +# make our ssh command one word only +if os_is_windows; then + fakessh=fakessh.bat + echo 'echo hello > touchedby_fakessh' > $fakessh +else + fakessh=./fakessh + echo '#!/bin/sh' > $fakessh + echo 'echo hello > touchedby_fakessh' >> $fakessh fi -export DARCS_SSH=$touch_fakessh -export DARCS_SCP=$touch_fakessh -export DARCS_SFTP=$touch_fakessh -rm -rf 'fakessh' -rm -rf 'touch-fakessh' +chmod u+x $fakessh -# make our ssh command one word only -echo 'echo hello > fakessh' > $touch_fakessh -chmod u+x $touch_fakessh +export DARCS_SSH=$fakessh +export DARCS_SCP=$fakessh +export DARCS_SFTP=$fakessh + # first test the DARCS_SSH environment variable +rm -rf touchedby_fakessh not darcs clone example.com:foo -grep hello fakessh -rm -f fakessh +grep hello touchedby_fakessh # now make sure that we don't launch ssh for nothing +rm -f touchedby_fakessh mkdir temp1 cd temp1 darcs init cd .. darcs clone temp1 > log -not grep fakessh log +not grep touchedby_fakessh log not darcs clone http://darcs.net/nonexistent -not grep fakessh log +not grep touchedby_fakessh log cd .. -rm -rf temp1 diff --git a/tests/send-external.sh b/tests/send-external.sh --- a/tests/send-external.sh +++ b/tests/send-external.sh @@ -2,9 +2,6 @@ . ./lib # The argument quoting in the test script below breaks on Windows paths -# Actually sending email from Windows is very unlikely anyway, so just -# skip this test. -abort_windows DARCS_EDITOR=echo export DARCS_EDITOR