issue2716 2024-02-25 13:04:51+00:00

.github/workflows/build-and-test.yml

@@ -27,6 +27,7 @@ jobs:
           - 9.2.8
           - 9.4.8
           - 9.6.4
+          - 9.8.1
         cabal:
           - '3.10'
         exclude:

Setup.hs

@@ -147,9 +147,9 @@ weakhash verbosity = do
   unless inrepo $ fail "Not a repository."
   out <- rawSystemStdout verbosity "darcs" ["show", "repo"]
   let line = filter ("Weak Hash:" `isInfixOf`) $ lines out
-  return $ case (length line) of
-                0 -> Nothing
-                _ -> Just $ last $ words $ head line
+  return $ case line of
+                [] -> Nothing
+                x:_ -> Just $ last $ words x
  `catchAny` \_ -> return Nothing
 
 context :: Verbosity -> IO (Maybe String)

darcs.cabal

@@ -442,9 +442,7 @@ Library
                       old-time          >= 1.1.0.3 && < 1.2,
                       time              >= 1.9 && < 1.14,
                       text              >= 1.2.1.3 && < 2.2,
-                      -- constraining to <1.3.8.0 to work around encoding problems
-                      -- see issue2716
-                      directory         >= 1.2.7 && < 1.3.8.0,
+                      directory         >= 1.2.7 && < 1.4,
                       temporary         >= 1.2.1 && < 1.4,
                       process           >= 1.2.3.0 && < 1.7,
                       array             >= 0.5.1.0 && < 0.6,

release/distributed-version

@@ -1 +1 @@
-Just 447
+Just 45

src/Darcs/UI/Commands/Pull.hs

@@ -320,10 +320,10 @@ makeBundle opts (Sealed (Fork common _ to_be_fetched)) =
     do
       bundle <- Bundle.makeBundle Nothing common $
                  mapFL_FL hopefully to_be_fetched
-      fname <- case to_be_fetched of
+      let fname = case to_be_fetched of
                     (x:>:_)-> getUniqueDPatchName $ patchDesc x
                     _ -> error "impossible case"
-      let o = fromMaybe stdOut (getOutput opts fname)
+      o <- fromMaybe (return stdOut) (getOutput opts fname)
       useAbsoluteOrStd writeDocBinFile putDoc o bundle
 
 {- Read in the specified pull-from repositories.  Perform

src/Darcs/UI/Commands/Send.hs

@@ -257,15 +257,15 @@ sendToThem repo opts wtds their_name them = do
   here   <- getCurrentDirectory
   let make_fname (tb:>:_) = getUniqueDPatchName $ patchDesc tb
       make_fname _ = error "impossible case"
-  fname <- make_fname to_be_sent
+  let fname = make_fname to_be_sent
   let outname = case getOutput opts fname of
                     Just f  -> Just f
                     Nothing | O.mail ? opts -> Nothing
                             | not $ null [ p | PostHttp p <- wtds] -> Nothing
-                            | otherwise        -> Just (makeAbsoluteOrStd here fname)
+                            | otherwise        -> Just (makeAbsoluteOrStd here <$> fname)
   case outname of
-    Just fname' -> writeBundleToFile opts to_be_sent bundle fname' wtds their_name
-    Nothing     -> sendBundle opts to_be_sent bundle fname wtds their_name
+    Just fname' -> fname' >>= \f -> writeBundleToFile opts to_be_sent bundle f wtds their_name
+    Nothing     -> fname >>= \f -> sendBundle opts to_be_sent bundle f wtds their_name
 
 
 prepareBundle :: forall p wX wY wZ. (RepoPatch p, ApplyState p ~ Tree)
@@ -427,7 +427,7 @@ decideOnBehavior opts remote_repo =
                 msg = willSendTo (dryRun ? opts) (map pn emails)
             in case dryRun ? opts of
                 O.YesDryRun -> putInfo opts msg
-                O.NoDryRun  -> when (null the_targets && isNothing (getOutput opts "")) $
+                O.NoDryRun  -> when (null the_targets && isNothing (getOutput opts (return ""))) $
                                 putInfo opts msg
 
 getTargets :: [WhatToDo] -> IO [WhatToDo]

src/Darcs/UI/Commands/Unrecord.hs

@@ -260,7 +260,7 @@ obliterateCmd cmdname _ opts _ = do
           "obliterate" verbOpt (O.withSummary ? opts) (dryRun ? opts)
           (xmlOutput ? opts) (isInteractive True opts) removed
         setEnvDarcsPatches removed
-        when (isJust $ getOutput opts "") $
+        when (isJust $ getOutput opts (return "")) $
           -- The call to preselectPatches above may have unwrapped the latest
           -- clean tag. If we don't want to remove it, we lost information
           -- about that tag being clean, so we have to access it's inventory.
@@ -298,8 +298,8 @@ savetoBundle opts removed@(x :>: _) orig = do
           Sealed (kept' :> removed') ->
             makeBundle Nothing kept' (mapFL_FL hopefully removed'))
           `catchInterrupt` genFullBundle
-  filename <- getUniqueDPatchName (patchDesc x)
-  let outname = fromJust (getOutput opts filename)
+  let filename = getUniqueDPatchName (patchDesc x)
+  outname <- fromJust (getOutput opts filename)
   exists <- useAbsoluteOrStd (doesPathExist . toFilePath) (return False) outname
   when exists $
     fail $ "Directory or file named '" ++ (show outname) ++ "' already exists."

src/Darcs/UI/Commands/Util.hs

@@ -36,6 +36,7 @@ import Control.Monad ( when, unless )
 
 import Darcs.Prelude
 
+import Control.Exception ( catch )
 import Data.Char ( isAlpha, toLower, isDigit, isSpace )
 import Data.Maybe ( fromMaybe )
 
@@ -204,13 +205,19 @@ getUniqueRepositoryName talkative name = getUniquePathName talkative buildMsg bu
                  n ++"'"
 
 getUniqueDPatchName :: FilePath -> IO FilePath
-getUniqueDPatchName name = getUniquePathName False (const "") buildName
+getUniqueDPatchName name =
+  catch
+    (getUniquePathName False (const "") buildName)
+    (\(e :: IOError) ->
+      fail $ "Error constructing filename corresponding to " ++ show name ++ ": " ++ show e ++
+             "\nConsider using '-o' to specify an output filename."
+    )
   where
     buildName i =
       if i == -1 then patchFilename name else patchFilename $ name++"_"++show i
 
 -- |patchFilename maps a patch description string to a safe (lowercased, spaces
--- removed and ascii-only characters) patch filename.
+-- removed and only letters/digits) patch filename.
 patchFilename :: String -> String
 patchFilename the_summary = name ++ ".dpatch"
   where

src/Darcs/UI/Flags.hs

@@ -429,11 +429,13 @@ getSendmailCmd fs =
     Nothing -> lookupEnv "SENDMAIL"
     justcmd -> return justcmd
 
--- | Accessor for output option
-getOutput :: Config -> FilePath -> Maybe AbsolutePathOrStd
+-- | Accessor for output option. Takes and returns IO actions
+-- so that the default value is only calculated if needed,
+-- as it might involve filesystem actions that can fail.
+getOutput :: Config -> IO FilePath -> Maybe (IO AbsolutePathOrStd)
 getOutput fs fp = fmap go (parseFlags O.output fs) where
-  go (O.Output ap)         = ap
-  go (O.OutputAutoName ap) = makeAbsoluteOrStd ap fp
+  go (O.Output ap)         = return ap
+  go (O.OutputAutoName ap) = makeAbsoluteOrStd ap <$> fp
 
 -- |'getSubject' takes a list of flags and returns the subject of the mail
 -- to be sent by @darcs send@. Looks for a subject specified by