File: Get.lhs

package info (click to toggle)
darcs 1.0.9~rc1-0.1
  • links: PTS
  • area: main
  • in suites: etch, etch-m68k
  • size: 4,248 kB
  • ctags: 565
  • sloc: haskell: 19,148; perl: 4,320; sh: 1,626; ansic: 1,137; makefile: 55; xml: 14
file content (300 lines) | stat: -rw-r--r-- 13,123 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
%  Copyright (C) 2002-2005 David Roundy
%
%  This program is free software; you can redistribute it and/or modify
%  it under the terms of the GNU General Public License as published by
%  the Free Software Foundation; either version 2, or (at your option)
%  any later version.
%
%  This program is distributed in the hope that it will be useful,
%  but WITHOUT ANY WARRANTY; without even the implied warranty of
%  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
%  GNU General Public License for more details.
%
%  You should have received a copy of the GNU General Public License
%  along with this program; if not, write to the Free Software Foundation,
%  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
\subsection{darcs get}
\begin{code}
module Get ( get ) where

import Directory ( setCurrentDirectory, doesDirectoryExist, doesFileExist,
                   createDirectory )
import Workaround ( getCurrentDirectory )
import Maybe ( isJust )
import Monad ( liftM, when )

import DarcsCommands ( DarcsCommand(..), nodefaults )
import DarcsArguments ( DarcsFlag( WorkDir, Partial,
                                   SetScriptsExecutable,
                                   Verbose, Quiet, Context ),
                        any_verbosity, partial, reponame,
                        match_one_context, set_default, set_scripts_executable,
                        disable_ssh_cm,
                        pristine_tree, working_repo_dir )
import DarcsRepo ( lazily_read_repo, write_inventory,
                    write_checkpoint_patch,
                    absolute_dir, get_checkpoint,
                    copy_repo_patches, sync_repo,
                    createPristineDirectoryTree,
                    apply_patches_with_feedback, simple_feedback,
                    slurp_all_but_darcs, write_patch, read_repo
                  )
import Patch ( apply, patch2patchinfo, invert, join_patches )
import PatchInfo( human_friendly )
import External ( copyFileOrUrl, Cachable(..) )
import Depends ( get_common_and_uncommon, get_patches_beyond_tag, commute_to_end )
import RepoPrefs ( set_defaultrepo, write_default_prefs )
import Motd ( show_motd )
import Pristine ( identifyPristine, createPristine,
                  createPristineFromWorking, flagsToPristine, applyPristine )
import Match ( have_patchset_match, get_one_patchset )
import DarcsUtils ( catchall, formatPath, withCurrentDirectory )
import Printer ( text, vcat, errorDoc, ($$), Doc, putDocLn, )
import SlurpDirectory ( list_slurpy_files )
import Workaround ( setExecutable )
import Unrecord ( rempatch )
import Repository ( patchSetToPatches )
import FastPackedString ( packString, readFilePS, takePS )
#include "impossible.h"
\end{code}
\begin{code}
get_description :: String
get_description =
 "Create a local copy of another repository."
\end{code}

\options{get}

If the remote repository and the current directory are in the same filesystem and
that filesystem supports hard links, get will create hard links for the
patch files, which means that the additional storage space needed will be
minimal.  This is \emph{very} good for your disk usage (and for the speed
of running get), so if you want multiple copies of a repository, I strongly
recommend first running \verb!darcs get! to get yourself one copy, and then
running \verb!darcs get! on that copy to make any more you like.  The only
catch is that the first time you run \verb!darcs push! or \verb!darcs pull!
from any of these second copies, by default they will access your first
copy---which may not be what you want.

You may specify the name of the repository created by providing a second
argument to get, which is a directory name.

\begin{code}
get_help :: String
get_help =
 "Get is used to get a local copy of a repository.\n"
\end{code}
\begin{code}
get :: DarcsCommand
get = DarcsCommand {command_name = "get",
                    command_help = get_help,
                    command_description = get_description,
                    command_extra_args = -1,
                    command_extra_arg_help = ["<REPOSITORY>", "[<DIRECTORY>]"],
                    command_command = get_cmd,
                    command_prereq = \_ -> return $ Right "",
                    command_get_arg_possibilities = return [],
                    command_argdefaults = nodefaults,
                    command_darcsoptions = [reponame,
                                            partial,
                                            match_one_context,
                                            any_verbosity,
                                            set_default,
                                            set_scripts_executable,
                                            pristine_tree,
                                            working_repo_dir,
                                            disable_ssh_cm]}
\end{code}
\begin{code}
get_cmd :: [DarcsFlag] -> [String] -> IO ()
get_cmd opts [inrepodir, outname] = get_cmd (WorkDir outname:opts) [inrepodir]
get_cmd orig_opts [inrepodir] = do
  former_dir <- getCurrentDirectory
  let opts = fix_context orig_opts
      fix_context o@(Context ('/':_):_) = o
      fix_context (Context f:os) = Context (former_dir++"/"++f):os
      fix_context (o:os) = o : fix_context os
      fix_context [] = []
  repodir <- absolute_dir inrepodir
  show_motd opts repodir
  patches <- lazily_read_repo repodir -- laziness doesn't matter here...
  when (Partial `elem` opts) $ putVerbose $ text "Reading checkpoint..."
  mch <- get_checkpoint opts repodir
  mysimplename <- make_repo_name opts repodir
  createDirectory mysimplename
  setCurrentDirectory mysimplename
  myname <- getCurrentDirectory
  createDirectory "_darcs"
  createDirectory "_darcs/patches"
  createPristine $ flagsToPristine opts
  createDirectory "_darcs/checkpoints"
  createDirectory "_darcs/prefs"
  write_default_prefs
  set_defaultrepo repodir opts
  putVerbose $ text "Getting the inventory..."
  write_inventory "." patches
  putVerbose $ text "Copying patches..."
  copy_repo_patches opts repodir "."
  putVerbose $ text "Patches copied"
  local_patches <- lazily_read_repo "."
  putVerbose $ text "Repo lazily read"
  repo_is_local <- doesDirectoryExist repodir
  putVerbose $ text $ "Repo local: " ++ formatPath (show repo_is_local)
  if repo_is_local && not (Partial `elem` opts)
     then do
       putVerbose $ text "Copying prefs"
       copyFileOrUrl
          (repodir++"/_darcs/prefs/prefs") "_darcs/prefs/prefs" (MaxAge 600)
          `catchall` return ()
       putVerbose $ text "Writing working directory"
       withCurrentDirectory repodir $ do
           pris <- identifyPristine
           createPristineDirectoryTree pris myname
       withCurrentDirectory myname $ do
           -- note: SetScriptsExecutable is normally checked in PatchApply
           -- but darcs get on local repositories does not apply patches
           if SetScriptsExecutable `elem` orig_opts
              then do putVerbose $ text "Making scripts executable"
                      c <- (liftM list_slurpy_files) (slurp_all_but_darcs myname)
                      let setExecutableIfScript f = 
                            do contents <- readFilePS f
                               when (takePS 2 contents == packString "#!") $ do
                                 putVerbose $ text ("Making executable: " ++ f)
                                 setExecutable f True
                      mapM setExecutableIfScript c
                      return ()
              else return ()
     else do
       setCurrentDirectory myname
       if Partial `elem` opts && isJust mch
          then let p_ch = fromJust mch
                   pi_ch = fromJust $ patch2patchinfo p_ch
                   needed_patches = reverse $ concat $
                                    get_patches_beyond_tag pi_ch local_patches
                   in do write_checkpoint_patch p_ch
                         apply opts False p_ch `catch`
                             \e -> fail ("Bad checkpoint!\n" ++ show e)
                         apply_patches_with_feedback opts False
                                  feedback putInfo needed_patches
          else apply_patches_with_feedback opts False feedback putInfo
                   $ reverse $ concat local_patches
  putVerbose $ text "Writing the pristine"
  pristine <- identifyPristine
  createPristineFromWorking pristine
  putVerbose $ text "Syncing the repository..."
  setCurrentDirectory myname
  sync_repo pristine
  putVerbose $ text "Repository synced, going to chosen version..."
  go_to_chosen_version putVerbose putInfo opts
  putInfo $ text "Finished getting."
      where am_verbose = Verbose `elem` orig_opts
            am_informative = not $ Quiet `elem` orig_opts
            putVerbose s = when am_verbose $ putDocLn s
            putInfo s = when am_informative $ putDocLn s
            feedback = simple_feedback orig_opts 

get_cmd _ _ = fail "You must provide 'get' with either one or two arguments."
\end{code}

\begin{code}
make_repo_name :: [DarcsFlag] -> FilePath -> IO String
make_repo_name (WorkDir n:_) _ =
    do exists <- doesDirectoryExist n
       file_exists <- doesFileExist n
       if exists || file_exists
          then fail $ "Directory or file named '" ++ n ++ "' already exists."
          else return n
make_repo_name (_:as) d = make_repo_name as d
make_repo_name [] d =
  case dropWhile (=='.') $ reverse $
       takeWhile (\c -> c /= '/' && c /= ':') $
       dropWhile (=='/') $ reverse d of
  "" -> modify_repo_name "anonymous_repo"
  base -> modify_repo_name base

modify_repo_name :: String -> IO String
modify_repo_name name =
    if head name == '/'
    then mrn name (-1)
    else do cwd <- getCurrentDirectory
            mrn (cwd ++ "/" ++ name) (-1)
 where
  mrn :: String -> Int -> IO String
  mrn n i = do
    exists <- doesDirectoryExist thename
    file_exists <- doesFileExist thename
    if not exists && not file_exists
       then do when (i /= -1) $
                    putStrLn $ "Directory '"++ n ++
                               "' already exists, creating repository as '"++
                               thename ++"'"
               return thename
       else mrn n $ i+1
    where thename = if i == -1 then n else n++"_"++show i
\end{code}

\begin{options}
--context, --tag, --to-patch, --to-match
\end{options}
If you want to get a specific version of a repository, you have a few
options.  You can either use the \verb!--tag!, \verb!--to-patch! or
\verb!--to-match! options, or you can use the \verb!--context=FILENAME!
option, which specifies a file containing a context generated with
\verb!darcs changes --context!.  This allows you (for example) to include in
your compiled program an option to output the precise version of the
repository from which it was generated, and then perhaps ask users to
include this information in bug reports.

Note that when specifying \verb!--to-patch! or \verb!--to-match!, you may
get a version of your code that has never before been seen, if the patches
have gotten themselves reordered.  If you ever want to be able to precisely
reproduce a given version, you need either to tag it or create a context
file.

\begin{code}
go_to_chosen_version :: (Doc -> IO ()) -> (Doc -> IO ())
                     -> [DarcsFlag] -> IO ()
go_to_chosen_version putVerbose putInfo opts =
    when (have_patchset_match opts) $ do
       putVerbose $ text "Going to specified version..."
       patches <- lazily_read_repo "."
       context <- get_one_patchset opts
       let (_,us',them') = get_common_and_uncommon (patches, context)
       case them' of
           [[]] -> return ()
           _ -> errorDoc $ text "Missing these patches from context:"
                        $$ (vcat $ map (human_friendly.fst) $ head them')
       let ps = patchSetToPatches us'
       putInfo $ text $ "Unapplying " ++ (show $ length ps) ++ " " ++ (patch_or_patches $ length ps)
       let (_, skipped) = commute_to_end ps patches
       sequence_ $ map (write_patch opts) skipped
       repo_patches <- read_repo "."
       write_inventory "." $ foldl (flip rempatch) repo_patches (reverse ps)
       pris <- identifyPristine
       applyPristine pris (invert $ join_patches ps) `catch` \e ->
           fail ("Unable to apply inverse patch!\n" ++ show e)
       apply opts False (invert $ join_patches ps) `catch` \e ->
           fail ("Couldn't undo patch in working dir.\n" ++ show e)
       sync_repo pris
                        
patch_or_patches :: Int -> String
patch_or_patches 1 = "patch."
patch_or_patches _ = "patches."
                        
\end{code}                        

\begin{options}
--partial
\end{options}
Only get the patches since the last checkpoint. This will save time, 
bandwidth and disk space, at the expense of losing the history before 
the checkpoint. 

\begin{options}
--no-pristine-tree
\end{options}
In order to save disk space, you can use {\tt get} with the
\verb|--no-pristine-tree| flag to create a repository with no pristine
tree.  Please see Section~\ref{disk-usage} for more information.