packages feed

git-annex 4.20130405 → 4.20130417

raw patch · 172 files changed

+4718/−763 lines, 172 filesdep +HTTPsetup-changedbinary-added

Dependencies added: HTTP

Files

.gitignore view
@@ -2,6 +2,10 @@ test build-stamp Build/SysConfig.hs+Build/InstallDesktopFile+Build/EvilSplicer+Build/Standalone+Build/OSXMkLibs git-annex git-annex.1 git-annex-shell.1@@ -9,6 +13,8 @@ doc/.ikiwiki html *.tix+*.o+*.hi .hpc dist # Sandboxed builds
Annex.hs view
@@ -5,7 +5,7 @@  - Licensed under the GNU GPL version 3 or higher.  -} -{-# LANGUAGE PackageImports, GeneralizedNewtypeDeriving, TypeFamilies, MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, MultiParamTypeClasses #-}  module Annex ( 	Annex,
Annex/Content.hs view
@@ -439,10 +439,20 @@  {- Downloads content from any of a list of urls. -} downloadUrl :: [Url.URLString] -> FilePath -> Annex Bool-downloadUrl urls file = do-	o <- map Param . annexWebOptions <$> Annex.getGitConfig-	headers <- getHttpHeaders-	liftIO $ anyM (\u -> Url.download u headers o file) urls+downloadUrl urls file = go =<< annexWebDownloadCommand <$> Annex.getGitConfig+  where+  	go Nothing = do+		opts <- map Param . annexWebOptions <$> Annex.getGitConfig+		headers <- getHttpHeaders+		liftIO $ anyM (\u -> Url.download u headers opts file) urls+	go (Just basecmd) = liftIO $ anyM (downloadcmd basecmd) urls+	downloadcmd basecmd url =+		boolSystem "sh" [Param "-c", Param $ gencmd url basecmd]+			<&&> doesFileExist file+	gencmd url = massReplace+		[ ("%file", shellEscape file)+		, ("%url", shellEscape url)+		]  {- Copies a key's content, when present, to a temp file.  - This is used to speed up some rsyncs. -}
Annex/Content/Direct.hs view
@@ -12,10 +12,12 @@ 	goodContent, 	recordedInodeCache, 	updateInodeCache,+	addInodeCache, 	writeInodeCache, 	compareInodeCaches, 	compareInodeCachesWith, 	sameInodeCache,+	elemInodeCaches, 	sameFileStatus, 	removeInodeCache, 	toInodeCache,@@ -101,21 +103,36 @@ goodContent :: Key -> FilePath -> Annex Bool goodContent key file = sameInodeCache file =<< recordedInodeCache key -{- Gets the recorded inode cache for a key. -}-recordedInodeCache :: Key -> Annex (Maybe InodeCache)+{- Gets the recorded inode cache for a key. + -+ - A key can be associated with multiple files, so may return more than+ - one. -}+recordedInodeCache :: Key -> Annex [InodeCache] recordedInodeCache key = withInodeCacheFile key $ \f ->-	liftIO $ catchDefaultIO Nothing $ readInodeCache <$> readFile f+	liftIO $ catchDefaultIO [] $+		mapMaybe readInodeCache . lines <$> readFile f -{- Stores a cache of attributes for a file that is associated with a key. -}+{- Caches an inode for a file.+ -+ - Anything else already cached is preserved.+ -} updateInodeCache :: Key -> FilePath -> Annex ()-updateInodeCache key file = maybe noop (writeInodeCache key)+updateInodeCache key file = maybe noop (addInodeCache key) 	=<< liftIO (genInodeCache file) -{- Writes a cache for a key. -}-writeInodeCache :: Key -> InodeCache -> Annex ()-writeInodeCache key cache = withInodeCacheFile key $ \f -> do+{- Adds another inode to the cache for a key. -}+addInodeCache :: Key -> InodeCache -> Annex ()+addInodeCache key cache = do+	oldcaches <- recordedInodeCache key+	unlessM (elemInodeCaches cache oldcaches) $+		writeInodeCache key (cache:oldcaches)++{- Writes inode cache for a key. -}+writeInodeCache :: Key -> [InodeCache] -> Annex ()+writeInodeCache key caches = withInodeCacheFile key $ \f -> do 	createContentDir f-	liftIO $ writeFile f $ showInodeCache cache+	liftIO $ writeFile f $+		unlines $ map showInodeCache caches  {- Removes an inode cache. -} removeInodeCache :: Key -> Annex ()@@ -127,12 +144,12 @@ withInodeCacheFile key a = a =<< calcRepo (gitAnnexInodeCache key)  {- Checks if a InodeCache matches the current version of a file. -}-sameInodeCache :: FilePath -> Maybe InodeCache -> Annex Bool-sameInodeCache _ Nothing = return False-sameInodeCache file (Just old) = go =<< liftIO (genInodeCache file)+sameInodeCache :: FilePath -> [InodeCache] -> Annex Bool+sameInodeCache _ [] = return False+sameInodeCache file old = go =<< liftIO (genInodeCache file)   where 	go Nothing = return False-	go (Just curr) = compareInodeCaches curr old+	go (Just curr) = elemInodeCaches curr old  {- Checks if a FileStatus matches the recorded InodeCache of a file. -} sameFileStatus :: Key -> FileStatus -> Annex Bool@@ -140,8 +157,8 @@ 	old <- recordedInodeCache key 	let curr = toInodeCache status 	case (old, curr) of-		(Just o, Just c) -> compareInodeCaches o c-		(Nothing, Nothing) -> return True+		(_, Just c) -> elemInodeCaches c old+		([], Nothing) -> return True 		_ -> return False  {- If the inodes have changed, only the size and mtime are compared. -}@@ -152,6 +169,13 @@ 		( return $ compareWeak x y 		, return False 		)++elemInodeCaches :: InodeCache -> [InodeCache] -> Annex Bool+elemInodeCaches _ [] = return False+elemInodeCaches c (l:ls) = ifM (compareInodeCaches c l)+	( return True+	, elemInodeCaches c ls+	)  compareInodeCachesWith :: Annex InodeComparisonType compareInodeCachesWith = ifM inodesChanged ( return Weakly, return Strongly )
Annex/Direct.hs view
@@ -52,8 +52,8 @@ 				 - it really was. -} 				oldcache <- recordedInodeCache key 				case oldcache of-					Nothing -> modifiedannexed file key cache-					Just c -> unlessM (compareInodeCaches c cache) $+					[] -> modifiedannexed file key cache+					_ -> unlessM (elemInodeCaches cache oldcache) $ 						modifiedannexed file key cache 			(Just key, Nothing, _) -> deletedannexed file key 			(Nothing, Nothing, _) -> deletegit file@@ -87,11 +87,11 @@ 	got Nothing = do 		showEndFail 		return False-	got (Just (key, _)) = ifM (sameInodeCache file $ Just cache)+	got (Just (key, _)) = ifM (sameInodeCache file [cache]) 		( do 			l <- inRepo $ gitAnnexLink file key 			stageSymlink file =<< hashSymlink l-			writeInodeCache key cache+			addInodeCache key cache 			void $ addAssociatedFile key file 			logStatus key InfoPresent 			showEndOk
Annex/Ssh.hs view
@@ -8,8 +8,9 @@ {-# LANGUAGE CPP #-}  module Annex.Ssh (-	sshParams,+	sshCachingOptions, 	sshCleanup,+	sshReadPort, ) where  import qualified Data.Map as M@@ -24,8 +25,8 @@  {- Generates parameters to ssh to a given host (or user@host) on a given  - port, with connection caching. -}-sshParams :: (String, Maybe Integer) -> [CommandParam] -> Annex [CommandParam]-sshParams (host, port) opts = go =<< sshInfo (host, port)+sshCachingOptions :: (String, Maybe Integer) -> [CommandParam] -> Annex [CommandParam]+sshCachingOptions (host, port) opts = go =<< sshInfo (host, port)   where 	go (Nothing, params) = ret params 	go (Just socketfile, params) = do@@ -33,8 +34,7 @@ 		liftIO $ createDirectoryIfMissing True $ parentDir socketfile 		lockFile $ socket2lock socketfile 		ret params-	ret ps = return $ ps ++ opts ++ portParams port ++-		[Param "-T", Param host]+	ret ps = return $ ps ++ opts ++ portParams port ++ [Param "-T"] 	-- If the lock pool is empty, this is the first ssh of this 	-- run. There could be stale ssh connections hanging around 	-- from a previous git-annex run that was interrupted.@@ -154,3 +154,15 @@  - appear on disk. -} valid_unix_socket_path :: FilePath -> Bool valid_unix_socket_path f = length (decodeW8 f) < sizeof_sockaddr_un_sun_path++{- Parses the SSH port, and returns the other OpenSSH options. If+ - several ports are found, the last one takes precedence. -}+sshReadPort :: [String] -> (Maybe Integer, [String])+sshReadPort params = (port, reverse args)+  where+	(port,args) = aux (Nothing, []) params+	aux (p,ps) [] = (p,ps)+	aux (_,ps) ("-p":p:rest) = aux (readPort p, ps) rest+	aux (p,ps) (q:rest) | "-p" `isPrefixOf` q = aux (readPort $ drop 2 q, ps) rest+			    | otherwise = aux (p,q:ps) rest+	readPort p = fmap fst $ listToMaybe $ reads p
Assistant.hs view
@@ -161,6 +161,7 @@ import qualified Build.SysConfig as SysConfig  import System.Log.Logger+import Network.Socket (HostName)  stopDaemon :: Annex () stopDaemon = liftIO . Utility.Daemon.stopDaemon =<< fromRepo gitAnnexPidFile@@ -170,8 +171,8 @@  -  - startbrowser is passed the url and html shim file, as well as the original  - stdout and stderr descriptors. -}-startDaemon :: Bool -> Bool -> Maybe (Maybe Handle -> Maybe Handle -> String -> FilePath -> IO ()) -> Annex ()-startDaemon assistant foreground startbrowser = do+startDaemon :: Bool -> Bool -> Maybe HostName ->  Maybe (Maybe Handle -> Maybe Handle -> String -> FilePath -> IO ()) -> Annex ()+startDaemon assistant foreground listenhost startbrowser = do 	pidfile <- fromRepo gitAnnexPidFile 	logfile <- fromRepo gitAnnexLogFile 	logfd <- liftIO $ openLog logfile@@ -218,7 +219,7 @@ 		mapM_ (startthread urlrenderer) 			[ watch $ commitThread #ifdef WITH_WEBAPP-			, assist $ webAppThread d urlrenderer False Nothing webappwaiter+			, assist $ webAppThread d urlrenderer False listenhost Nothing webappwaiter #ifdef WITH_PAIRING 			, assist $ pairListenerThread urlrenderer #endif
Assistant/Alert.hs view
@@ -81,6 +81,11 @@ startupScanAlert = activityAlert Nothing 	[Tensed "Performing" "Performed", "startup scan"] +{- Displayed when a shutdown is occurring, so will be seen after shutdown+ - has happened. -}+shutdownAlert :: Alert+shutdownAlert = warningAlert "shutdown" "git-annex has been shut down"+ commitAlert :: Alert commitAlert = activityAlert Nothing 	[Tensed "Committing" "Committed", "changes to git"]@@ -94,6 +99,7 @@ 	, alertHeader = Just $ tenseWords 		[Tensed "Syncing" "Synced", "with", showRemotes rs] 	, alertPriority = Low+	, alertIcon = Just SyncIcon 	}  syncResultAlert :: [Remote] -> [Remote] -> Alert
+ Assistant/Install/AutoStart.o view

binary file changed (absent → 3364 bytes)

Assistant/MakeRemote.hs view
@@ -32,7 +32,7 @@ 	r <- liftAnnex $ 		addRemote $ maker (sshRepoName sshdata) sshurl 	liftAnnex $ maybe noop (setRemoteCost r) mcost-	syncNewRemote r+	syncRemote r 	return r   where 	rsync = forcersync || rsyncOnly sshdata@@ -69,11 +69,15 @@ 		, ("type", "rsync") 		] -{- Inits a special remote. -}+{- Inits a special remote. Currently, only 'weak' ciphers can be+ - generated from the assistant, because otherwise GnuPG may block once+ - the entropy pool is drained, and as of now there's no way to tell the+ - user to perform IO actions to refill the pool. -} makeSpecialRemote :: String -> RemoteType -> R.RemoteConfig -> Annex () makeSpecialRemote name remotetype config = do 	(u, c) <- Command.InitRemote.findByName name-	c' <- R.setup remotetype u $ M.union config c+	c' <- R.setup remotetype u $+		M.insert "highRandomQuality" "false" $ M.union config c 	describeUUID u name 	configSet u c'
Assistant/Monad.hs view
@@ -5,7 +5,7 @@  - Licensed under the GNU GPL version 3 or higher.  -} -{-# LANGUAGE PackageImports, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}  module Assistant.Monad ( 	Assistant,
Assistant/Ssh.hs view
@@ -160,11 +160,18 @@ {- Installs a ssh key pair, and sets up ssh config with a mangled hostname  - that will enable use of the key. This way we avoid changing the user's  - regular ssh experience at all. Returns a modified SshData containing the- - mangled hostname. -}+ - mangled hostname.+ -+ - Note that the key files are put in ~/.ssh/git-annex/, rather than directly+ - in ssh because of an **INSANE** behavior of gnome-keyring: It loads+ - ~/.ssh/*.pub, and uses them indiscriminately. But using this key+ - for a normal login to the server will force git-annex-shell to run,+ - and locks the user out. Luckily, it does not recurse into subdirectories.+ -} setupSshKeyPair :: SshKeyPair -> SshData -> IO SshData setupSshKeyPair sshkeypair sshdata = do 	sshdir <- sshDir-	createDirectoryIfMissing True sshdir+	createDirectoryIfMissing True $ parentDir $ sshdir </> sshprivkeyfile  	unlessM (doesFileExist $ sshdir </> sshprivkeyfile) $ do 		h <- fdToHandle =<<@@ -178,7 +185,7 @@ 	setSshConfig sshdata 		[ ("IdentityFile", "~/.ssh/" ++ sshprivkeyfile) ]   where-	sshprivkeyfile = "key." ++ mangleSshHostName sshdata+	sshprivkeyfile = "git-annex" </> "key." ++ mangleSshHostName sshdata 	sshpubkeyfile = sshprivkeyfile ++ ".pub"  {- Setups up a ssh config with a mangled hostname.@@ -203,18 +210,27 @@ 		, ("Port", show $ sshPort sshdata) 		] +{- This hostname is specific to a given repository on the ssh host,+ - so it is based on the real hostname, the username, and the directory.+ -} mangleSshHostName :: SshData -> String-mangleSshHostName sshdata = "git-annex-" ++ host ++ (maybe "-" ('-':) user)+mangleSshHostName sshdata = "git-annex-" ++ T.unpack (sshHostName sshdata)+	++ "-" ++ filter safe extra   where-	host = T.unpack $ sshHostName sshdata-	user = T.unpack <$> sshUserName sshdata+	extra = join "_" $ map T.unpack $ catMaybes+		[ sshUserName sshdata+		, Just $ sshDirectory sshdata+		]+	safe c+		| isAlphaNum c = True+		| c == '_' = True+		| otherwise = False +{- Extracts the real hostname from a mangled ssh hostname. -} unMangleSshHostName :: String -> String-unMangleSshHostName h-	| "git-annex-" `isPrefixOf` h = join "-" (beginning $ drop 2 dashbits)-	| otherwise = h-  where-	dashbits = split "-" h+unMangleSshHostName h = case split "-" h of+	("git":"annex":rest) -> join "-" (beginning rest)+	_ -> h  {- Does ssh have known_hosts data for a hostname? -} knownHost :: Text -> IO Bool
Assistant/Sync.hs view
@@ -204,9 +204,9 @@ 		sendNetMessage $ Pushing (getXMPPClientID r) PushRequest 	return (catMaybes failed, haddiverged) -{- Start syncing a newly added remote, using a background thread. -}-syncNewRemote :: Remote -> Assistant ()-syncNewRemote remote = do+{- Start syncing a remote, using a background thread. -}+syncRemote :: Remote -> Assistant ()+syncRemote remote = do 	updateSyncRemotes 	thread <- asIO $ do 		reconnectRemotes False [remote]
Assistant/Threads/Committer.hs view
@@ -297,13 +297,10 @@ 	removedKeysMap ct l = do 		mks <- forM (filter isRmChange l) $ \c -> 			catKeyFile $ changeFile c-		M.fromList . catMaybes <$> forM (catMaybes mks) mkpair+		M.fromList . concat <$> mapM mkpairs (catMaybes mks) 	  where-		mkpair k = do-			mcache <- recordedInodeCache k-			case mcache of-				Just cache -> return $ Just (inodeCacheToKey ct cache, k)-				Nothing -> return Nothing+		mkpairs k = map (\c -> (inodeCacheToKey ct c, k)) <$>+			recordedInodeCache k  	failedingest = do 		liftAnnex showEndFail
Assistant/Threads/Watcher.hs view
@@ -80,7 +80,10 @@ 	startup <- asIO1 startupScan 	matcher <- liftAnnex $ largeFilesMatcher 	direct <- liftAnnex isDirect-	addhook <- hook $ if direct then onAddDirect matcher else onAdd matcher+	symlinkssupported <- liftAnnex $ coreSymlinks <$> Annex.getGitConfig+	addhook <- hook $ if direct+		then onAddDirect symlinkssupported matcher+		else onAdd matcher 	delhook <- hook onDel 	addsymlinkhook <- hook $ onAddSymlink direct 	deldirhook <- hook onDelDir@@ -188,9 +191,10 @@ 	| otherwise = noChange  {- In direct mode, add events are received for both new files, and- - modified existing files. -}-onAddDirect :: FileMatcher -> Handler-onAddDirect matcher file fs = do+ - modified existing files.+ -}+onAddDirect :: Bool -> FileMatcher -> Handler+onAddDirect symlinkssupported matcher file fs = do 	v <- liftAnnex $ catKeyFile file 	case (v, fs) of 		(Just key, Just filestatus) ->@@ -203,37 +207,59 @@ 				( do 					link <- liftAnnex $ inRepo $ gitAnnexLink file key 					addLink file link (Just key)-				, do+				, guardSymlinkStandin (Just key) $ do 					debug ["changed direct", file] 					liftAnnex $ changedDirect key file 					add matcher file 				)-		_ -> do+		_ -> guardSymlinkStandin Nothing $ do 			debug ["add direct", file] 			add matcher file+  where+ 	{- On a filesystem without symlinks, we'll get changes for regular+	 - files that git uses to stand-in for symlinks. Detect when+	 - this happens, and stage the symlink, rather than annexing the+	 - file. -}+	guardSymlinkStandin mk a+		| symlinkssupported = a+		| otherwise = do+			linktarget <- liftAnnex $ getAnnexLinkTarget file+			liftIO $ print (file, linktarget)+			case linktarget of+				Nothing -> a+				Just lt -> do+					case fileKey $ takeFileName lt of+						Nothing -> noop+						Just key -> void $ liftAnnex $+							addAssociatedFile key file+					onAddSymlink' linktarget mk True file fs  {- A symlink might be an arbitrary symlink, which is just added.  - Or, if it is a git-annex symlink, ensure it points to the content  - before adding it.  -} onAddSymlink :: Bool -> Handler-onAddSymlink isdirect file filestatus = go =<< liftAnnex (Backend.lookupFile file)+onAddSymlink isdirect file filestatus = do+	linktarget <- liftIO (catchMaybeIO $ readSymbolicLink file)+	kv <- liftAnnex (Backend.lookupFile file)+	onAddSymlink' linktarget (fmap fst kv) isdirect file filestatus++onAddSymlink' :: Maybe String -> Maybe Key -> Bool -> Handler+onAddSymlink' linktarget mk isdirect file filestatus = go mk   where-	go (Just (key, _)) = do+  	go (Just key) = do 		when isdirect $ 			liftAnnex $ void $ addAssociatedFile key file 		link <- liftAnnex $ inRepo $ gitAnnexLink file key-		ifM ((==) (Just link) <$> liftIO (catchMaybeIO $ readSymbolicLink file))-			( ensurestaged (Just link) (Just key) =<< getDaemonStatus-			, do+		if linktarget == Just link+			then ensurestaged (Just link) =<< getDaemonStatus+			else do 				unless isdirect $ 					liftAnnex $ replaceFile file $ 						makeAnnexLink link 				addLink file link (Just key)-			)-	go Nothing = do -- other symlink-		mlink <- liftIO (catchMaybeIO $ readSymbolicLink file)-		ensurestaged mlink Nothing =<< getDaemonStatus+	-- other symlink, not git-annex+	go Nothing = ensurestaged linktarget =<< getDaemonStatus  	{- This is often called on symlinks that are already 	 - staged correctly. A symlink may have been deleted@@ -246,13 +272,13 @@ 	 - (If the daemon has never ran before, avoid staging 	 - links too.) 	 -}-	ensurestaged (Just link) mk daemonstatus+	ensurestaged (Just link) daemonstatus 		| scanComplete daemonstatus = addLink file link mk 		| otherwise = case filestatus of 			Just s 				| not (afterLastDaemonRun (statusChangeTime s) daemonstatus) -> noChange 			_ -> addLink file link mk-	ensurestaged Nothing _ _ = noChange+	ensurestaged Nothing _ = noChange  {- For speed, tries to reuse the existing blob for symlink target. -} addLink :: FilePath -> FilePath -> Maybe Key -> Assistant (Maybe Change)
Assistant/Threads/WebApp.hs view
@@ -38,7 +38,7 @@  import Yesod import Yesod.Static-import Network.Socket (SockAddr)+import Network.Socket (SockAddr, HostName) import Data.Text (pack, unpack)  mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")@@ -49,24 +49,26 @@ 	:: AssistantData 	-> UrlRenderer 	-> Bool+	-> Maybe HostName 	-> Maybe (IO String) 	-> Maybe (Url -> FilePath -> IO ()) 	-> NamedThread-webAppThread assistantdata urlrenderer noannex postfirstrun onstartup = thread $ liftIO $ do+webAppThread assistantdata urlrenderer noannex listenhost postfirstrun onstartup = thread $ liftIO $ do 	webapp <- WebApp 		<$> pure assistantdata 		<*> (pack <$> genRandomToken) 		<*> getreldir-		<*> pure $(embed "static")+		<*> pure staticRoutes 		<*> pure postfirstrun 		<*> pure noannex+		<*> pure listenhost 	setUrlRenderer urlrenderer $ yesodRender webapp (pack "") 	app <- toWaiAppPlain webapp 	app' <- ifM debugEnabled 		( return $ httpDebugLogger app 		, return app 		)-	runWebApp app' $ \addr -> if noannex+	runWebApp listenhost app' $ \addr -> if noannex 		then withTempFile "webapp.html" $ \tmpfile _ -> 			go addr webapp tmpfile Nothing 		else do
Assistant/Types/Alert.hs view
@@ -50,7 +50,7 @@ 	, alertButton :: Maybe AlertButton 	} -data AlertIcon = ActivityIcon | SuccessIcon | ErrorIcon | InfoIcon | TheCloud+data AlertIcon = ActivityIcon | SyncIcon | SuccessIcon | ErrorIcon | InfoIcon | TheCloud  type AlertMap = M.Map AlertId Alert
Assistant/Types/NetMessager.hs view
@@ -42,13 +42,18 @@ 	-- indicates that a push is starting 	| StartingPush 	-- a chunk of output of git receive-pack-	| ReceivePackOutput ByteString+	| ReceivePackOutput SequenceNum ByteString 	-- a chuck of output of git send-pack-	| SendPackOutput ByteString+	| SendPackOutput SequenceNum ByteString 	-- sent when git receive-pack exits, with its exit code 	| ReceivePackDone ExitCode 	deriving (Show, Eq, Ord) +{- A sequence number. Incremented by one per packet in a sequence,+ - starting with 1 for the first packet. 0 means sequence numbers are+ - not being used. -}+type SequenceNum = Int+ {- NetMessages that are important (and small), and should be stored to be  - resent when new clients are seen. -} isImportantNetMessage :: NetMessage -> Maybe ClientID@@ -64,8 +69,8 @@ {- Convert a NetMessage to something that can be logged. -} sanitizeNetMessage :: NetMessage -> NetMessage sanitizeNetMessage (Pushing c stage) = Pushing c $ case stage of-	ReceivePackOutput _ -> ReceivePackOutput elided-	SendPackOutput _ -> SendPackOutput elided+	ReceivePackOutput n _ -> ReceivePackOutput n elided+	SendPackOutput n _ -> SendPackOutput n elided 	s -> s   where   	elided = B8.pack "<elided>"@@ -85,8 +90,8 @@ pushDestinationSide CanPush = ReceivePack pushDestinationSide PushRequest = SendPack pushDestinationSide StartingPush = ReceivePack-pushDestinationSide (ReceivePackOutput _) = SendPack-pushDestinationSide (SendPackOutput _) = ReceivePack+pushDestinationSide (ReceivePackOutput _ _) = SendPack+pushDestinationSide (SendPackOutput _ _) = ReceivePack pushDestinationSide (ReceivePackDone _) = SendPack  type SideMap a = PushSide -> a
Assistant/WebApp/Configurators/AWS.hs view
@@ -191,7 +191,7 @@ 		makeSpecialRemote hostname remotetype config 		return remotename 	setup r-	liftAssistant $ syncNewRemote r+	liftAssistant $ syncRemote r 	redirect $ EditNewCloudRepositoryR $ Remote.uuid r   where 	{- AWS services use the remote name as the basis for a host
Assistant/WebApp/Configurators/Edit.hs view
@@ -14,6 +14,7 @@ import Assistant.DaemonStatus import Assistant.MakeRemote (uniqueRemoteName) import Assistant.WebApp.Configurators.XMPP (xmppNeeded)+import Assistant.ScanRemotes import qualified Remote import qualified Types.Remote as Remote import qualified Remote.List as Remote@@ -60,18 +61,12 @@  setRepoConfig :: UUID -> Maybe Remote -> RepoConfig -> RepoConfig -> Handler () setRepoConfig uuid mremote oldc newc = do-	when (repoDescription oldc /= repoDescription newc) $ liftAnnex $ do+	when descriptionChanged $ liftAnnex $ do 		maybe noop (describeUUID uuid . T.unpack) (repoDescription newc) 		void uuidMapLoad-	when (repoGroup oldc /= repoGroup newc) $ liftAnnex $ -		case repoGroup newc of-			RepoGroupStandard g -> setStandardGroup uuid g-			RepoGroupCustom s -> groupSet uuid $ S.fromList $ words s-	when (repoSyncable oldc /= repoSyncable newc) $-		changeSyncable mremote (repoSyncable newc)-	when (isJust mremote && makeLegalName (T.unpack $ repoName oldc) /= makeLegalName (T.unpack $ repoName newc)) $ do+	when nameChanged $ do 		liftAnnex $ do-			name <- fromRepo $ uniqueRemoteName (T.unpack $ repoName newc) 0+			name <- fromRepo $ uniqueRemoteName (legalName newc) 0 			{- git remote rename expects there to be a 			 - remote.<name>.fetch, and exits nonzero if 			 - there's not. Special remotes don't normally@@ -90,6 +85,28 @@ 				] 			void $ Remote.remoteListRefresh 		liftAssistant updateSyncRemotes+	when groupChanged $ do+		liftAnnex $ case repoGroup newc of+			RepoGroupStandard g -> setStandardGroup uuid g+			RepoGroupCustom s -> groupSet uuid $ S.fromList $ words s+		{- Enabling syncing will cause a scan,+		 - so avoid queueing a duplicate scan. -}+		when (repoSyncable newc && not syncableChanged) $ liftAssistant $+			case mremote of+				Just remote -> do+					addScanRemotes True [remote]+				Nothing -> do+					addScanRemotes True+						=<< syncDataRemotes <$> getDaemonStatus+	when syncableChanged $+		changeSyncable mremote (repoSyncable newc)+  where+  	syncableChanged = repoSyncable oldc /= repoSyncable newc+	groupChanged = repoGroup oldc /= repoGroup newc+	nameChanged = isJust mremote && legalName oldc /= legalName newc+	descriptionChanged = repoDescription oldc /= repoDescription newc++	legalName = makeLegalName . T.unpack . repoName  editRepositoryAForm :: RepoConfig -> AForm WebApp WebApp RepoConfig editRepositoryAForm def = RepoConfig
Assistant/WebApp/Configurators/Local.hs view
@@ -10,9 +10,9 @@ module Assistant.WebApp.Configurators.Local where  import Assistant.WebApp.Common-import Assistant.WebApp.Utility import Assistant.WebApp.OtherRepos import Assistant.MakeRemote+import Assistant.Sync import Init import qualified Git import qualified Git.Construct@@ -166,7 +166,7 @@ getCombineRepositoryR :: FilePathAndUUID -> Handler RepHtml getCombineRepositoryR (FilePathAndUUID newrepopath newrepouuid) = do 	r <- combineRepos newrepopath remotename-	syncRemote r+	liftAssistant $ syncRemote r 	redirect $ EditRepositoryR newrepouuid   where 	remotename = takeFileName newrepopath@@ -244,7 +244,7 @@ 		u <- liftIO $ initRepo isnew False dir $ Just remotename 		r <- combineRepos dir remotename 		liftAnnex $ setStandardGroup u TransferGroup-		syncRemote r+		liftAssistant $ syncRemote r 		return u   	mountpoint = T.unpack (mountPoint drive) 	dir = removableDriveRepository drive
Assistant/WebApp/Configurators/Pairing.hs view
@@ -37,8 +37,8 @@ import Utility.UserInfo import Git -#ifdef WITH_PAIRING import qualified Data.Text as T+#ifdef WITH_PAIRING import qualified Data.Text.Encoding as T import qualified Data.ByteString.Lazy as B import Data.Char@@ -87,9 +87,6 @@ 			$(widgetFile "configurators/pairing/xmpp/self/prompt") #else getStartXMPPPairSelfR = noXMPPPairing--noXMPPPairing :: Handler RepHtml-noXMPPPairing = noPairing "XMPP" #endif  getRunningXMPPPairFriendR :: BuddyKey -> Handler RepHtml@@ -187,7 +184,7 @@ 			finishXMPPPairing theirjid theiruuid 		xmppPairStatus False $ Just theirjid #else-getFinishXMPPPairR _ = noXMPPPairing+getFinishXMPPPairFriendR _ = noXMPPPairing #endif  {- Displays a page indicating pairing status and
Assistant/WebApp/Configurators/WebDAV.hs view
@@ -128,6 +128,6 @@ 		makeSpecialRemote name WebDAV.remote config 		return remotename 	setup r-	liftAssistant $ syncNewRemote r+	liftAssistant $ syncRemote r 	redirect $ EditNewCloudRepositoryR $ Remote.uuid r #endif
Assistant/WebApp/Configurators/XMPP.hs view
@@ -64,6 +64,7 @@ checkCloudRepos _ _ = noop #endif +#ifdef WITH_XMPP {- Returns the name of the friend corresponding to a  - repository's UUID, but not if it's our name. -} getBuddyName :: UUID -> Assistant (Maybe String)@@ -78,6 +79,7 @@ 		<$> getXMPPRemotes 	getclientjid = maybe Nothing parseJID . xmppClientID 		<$> getDaemonStatus+#endif  getNeedCloudRepoR :: UUID -> Handler RepHtml #ifdef WITH_XMPP@@ -85,7 +87,7 @@ 	buddyname <- liftAssistant $ getBuddyName for 	$(widgetFile "configurators/xmpp/needcloudrepo") #else-getNeedCloudRepoR = xmppPage $+getNeedCloudRepoR _ = xmppPage $ 	$(widgetFile "configurators/xmpp/disabled") #endif @@ -109,7 +111,7 @@ 		liftAssistant notifyNetMessagerRestart 		redirectUltDest DashboardR #else-getXMPPR = xmppPage $+postXMPPR = xmppPage $ 	$(widgetFile "configurators/xmpp/disabled") #endif
Assistant/WebApp/Control.hs view
@@ -13,6 +13,8 @@ import Locations.UserConfig import Utility.LogFile import Assistant.DaemonStatus+import Assistant.WebApp.Utility+import Assistant.Alert  import Control.Concurrent import System.Posix (getProcessID, signalProcess, sigTERM)@@ -23,13 +25,24 @@ 	$(widgetFile "control/shutdown")  getShutdownConfirmedR :: Handler RepHtml-getShutdownConfirmedR = page "Shutdown" Nothing $ do-	{- Wait 2 seconds before shutting down, to give the web page time-	 - to display. -}-	void $ liftIO $ forkIO $ do-		threadDelay 2000000-		signalProcess sigTERM =<< getProcessID-	$(widgetFile "control/shutdownconfirmed")+getShutdownConfirmedR = do+	{- Remove all alerts for currently running activities. -}+	liftAssistant $ do+		updateAlertMap $ M.filter $ \a -> alertClass a /= Activity+		void $ addAlert shutdownAlert+	{- Stop transfers the assistant is running,+	 - otherwise they would continue past shutdown.+	 - Pausing transfers prevents more being started up (and stops+	 - the transfer processes). -}+	ts <- liftAssistant $ M.keys . currentTransfers <$> getDaemonStatus+	mapM_ pauseTransfer ts+	page "Shutdown" Nothing $ do+		{- Wait 2 seconds before shutting down, to give the web+		 - page time to load in the browser. -}+		void $ liftIO $ forkIO $ do+			threadDelay 2000000+			signalProcess sigTERM =<< getProcessID+		$(widgetFile "control/shutdownconfirmed")  {- Quite a hack, and doesn't redirect the browser window. -} getRestartR :: Handler RepHtml
Assistant/WebApp/SideBar.hs view
@@ -88,8 +88,9 @@ 			redirect $ buttonUrl b 		_ -> redirectBack -htmlIcon :: AlertIcon -> GWidget sub master ()-htmlIcon ActivityIcon = bootstrapIcon "refresh"+htmlIcon :: AlertIcon -> GWidget WebApp WebApp ()+htmlIcon ActivityIcon = [whamlet|<img src="@{StaticR activityicon_gif}" alt="">|]+htmlIcon SyncIcon = [whamlet|<img src="@{StaticR syncicon_gif}" alt="">|] htmlIcon InfoIcon = bootstrapIcon "info-sign" htmlIcon SuccessIcon = bootstrapIcon "ok" htmlIcon ErrorIcon = bootstrapIcon "exclamation-sign"
Assistant/WebApp/Types.hs view
@@ -26,9 +26,13 @@ import Yesod.Static import Text.Hamlet import Data.Text (Text, pack, unpack)+import Network.Socket (HostName)  publicFiles "static" +staticRoutes :: Static+staticRoutes = $(embed "static")+ mkYesodData "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")  data WebApp = WebApp@@ -38,6 +42,7 @@ 	, getStatic :: Static 	, postFirstRun :: Maybe (IO String) 	, noAnnex :: Bool+	, listenHost ::Maybe HostName 	}  instance Yesod WebApp where
Assistant/WebApp/Utility.hs view
@@ -44,7 +44,7 @@ 		| otherwise = PauseWatcher changeSyncable (Just r) True = do 	changeSyncFlag r True-	syncRemote r+	liftAssistant $ syncRemote r changeSyncable (Just r) False = do 	changeSyncFlag r False 	liftAssistant $ updateSyncRemotes@@ -63,10 +63,6 @@ 	void $ Remote.remoteListRefresh   where 	key = Config.remoteConfig (Remote.repo r) "sync"--{- Start syncing remote, using a background thread. -}-syncRemote :: Remote -> Handler ()-syncRemote = liftAssistant . syncNewRemote  pauseTransfer :: Transfer -> Handler () pauseTransfer = cancelTransfer True
Assistant/XMPP.hs view
@@ -134,13 +134,13 @@ 	encode CanPush = gitAnnexTag canPushAttr T.empty 	encode PushRequest = gitAnnexTag pushRequestAttr T.empty 	encode StartingPush = gitAnnexTag startingPushAttr T.empty-	encode (ReceivePackOutput b) = -		gitAnnexTagContent receivePackAttr T.empty $ encodeTagContent b-	encode (SendPackOutput b) =-		gitAnnexTagContent sendPackAttr T.empty $ encodeTagContent b+	encode (ReceivePackOutput n b) = +		gitAnnexTagContent receivePackAttr (val n) $ encodeTagContent b+	encode (SendPackOutput n b) =+		gitAnnexTagContent sendPackAttr (val n) $ encodeTagContent b 	encode (ReceivePackDone code) =-		gitAnnexTag receivePackDoneAttr $ -			T.pack $ show $ encodeExitCode code+		gitAnnexTag receivePackDoneAttr $ val $ encodeExitCode code+	val = T.pack . show  decodeMessage :: Message -> Maybe NetMessage decodeMessage m = decode =<< gitAnnexTagInfo m@@ -160,10 +160,8 @@ 		, pushdecoder $ const $ Just CanPush 		, pushdecoder $ const $ Just PushRequest 		, pushdecoder $ const $ Just StartingPush-		, pushdecoder $ -			fmap ReceivePackOutput . decodeTagContent . tagElement-		, pushdecoder $-			fmap SendPackOutput . decodeTagContent . tagElement+		, pushdecoder $ gen ReceivePackOutput+		, pushdecoder $ gen SendPackOutput 		, pushdecoder $ 			fmap (ReceivePackDone . decodeExitCode) . readish . 				T.unpack . tagValue@@ -171,6 +169,10 @@ 	pushdecoder a m' i = Pushing 		<$> (formatJID <$> messageFrom m') 		<*> a i+	gen c i = do+	  	packet <- decodeTagContent $ tagElement i+		let seqnum = fromMaybe 0 $ readish $ T.unpack $ tagValue i+		return $ c seqnum packet  decodeExitCode :: Int -> ExitCode decodeExitCode 0 = ExitSuccess
Assistant/XMPP/Git.hs view
@@ -60,7 +60,7 @@ 	liftAnnex $ void remoteListRefresh 	remote' <- liftAnnex $ fromMaybe (error "failed to add remote") 		<$> Remote.byName (Just buddyname)-	syncNewRemote remote'+	syncRemote remote' 	return True  {- Pushes over XMPP, communicating with a specific client.@@ -108,7 +108,7 @@ 	outh <- liftIO $ fdToHandle writepush 	controlh <- liftIO $ fdToHandle writecontrol 	-	t1 <- forkIO <~> toxmpp inh+	t1 <- forkIO <~> toxmpp 0 inh 	t2 <- forkIO <~> fromxmpp outh controlh  	{- This can take a long time to run, so avoid running it in the@@ -122,15 +122,19 @@  	return r   where-	toxmpp inh = forever $ do+	toxmpp seqnum inh = do 		b <- liftIO $ B.hGetSome inh chunkSize 		if B.null b 			then liftIO $ killThread =<< myThreadId-			else sendNetMessage $ Pushing cid $ SendPackOutput b+			else do+				let seqnum' = succ seqnum+				sendNetMessage $ Pushing cid $+					SendPackOutput seqnum' b+				toxmpp seqnum' inh 	fromxmpp outh controlh = forever $ do 		m <- timeout xmppTimeout <~> waitNetPushMessage SendPack 		case m of-			(Just (Pushing _ (ReceivePackOutput b))) -> +			(Just (Pushing _ (ReceivePackOutput _ b))) ->  				liftIO $ writeChunk outh b 			(Just (Pushing _ (ReceivePackDone exitcode))) -> 				liftIO $ do@@ -213,7 +217,7 @@ 		} 	(Just inh, Just outh, _, pid) <- liftIO $ createProcess p 	readertid <- forkIO <~> relayfromxmpp inh-	relaytoxmpp outh+	relaytoxmpp 0 outh 	code <- liftIO $ waitForProcess pid 	void $ sendNetMessage $ Pushing cid $ ReceivePackDone code 	liftIO $ do@@ -222,16 +226,17 @@ 		hClose outh 		return $ code == ExitSuccess   where-	relaytoxmpp outh = do+	relaytoxmpp seqnum outh = do 		b <- liftIO $ B.hGetSome outh chunkSize 		-- empty is EOF, so exit 		unless (B.null b) $ do-			sendNetMessage $ Pushing cid $ ReceivePackOutput b-			relaytoxmpp outh+			let seqnum' = succ seqnum+			sendNetMessage $ Pushing cid $ ReceivePackOutput seqnum' b+			relaytoxmpp seqnum' outh 	relayfromxmpp inh = forever $ do 		m <- timeout xmppTimeout <~> waitNetPushMessage ReceivePack 		case m of-			(Just (Pushing _ (SendPackOutput b))) ->+			(Just (Pushing _ (SendPackOutput _ b))) -> 				liftIO $ writeChunk inh b 			(Just _) -> noop 			Nothing -> do
Build/Configure.hs view
@@ -8,9 +8,12 @@ import Control.Applicative import System.FilePath import System.Environment+import Data.Maybe  import Build.TestConfig import Utility.SafeCommand+import Utility.Monad+import Utility.Exception  tests :: [TestCase] tests =@@ -70,14 +73,34 @@ 	cmd = "cp " ++ option 	cmdline = cmd ++ " " ++ testFile ++ " " ++ testFile ++ ".new" -{- Pulls package version out of the changelog. -}+{- Version is usually based on the major version from the changelog, + - plus the date of the last commit, plus the git rev of that commit.+ - This works for autobuilds, ad-hoc builds, etc.+ -+ - For official builds, VERSION_FROM_CHANGELOG makes it use just the most+ - recent version from the changelog.+ -+ - If git or a git repo is not available, or something goes wrong,+ - just use the version from the changelog. -} getVersion :: Test getVersion = do-	version <- getVersionString+	changelogversion <- getChangelogVersion+	version <- ifM (isJust <$> catchMaybeIO (getEnv "VERSION_FROM_CHANGELOG"))+		( return changelogversion+		, catchDefaultIO changelogversion $ do+			let major = takeWhile (/= '.') changelogversion+			autoversion <- readProcess "sh"+				[ "-c"+				, "git log -n 1 --format=format:'%ci %h'| sed -e 's/-//g' -e 's/ .* /-g/'"+				] ""+			if null autoversion+				then return changelogversion+				else return $ concat [ major, ".", autoversion ]+		) 	return $ Config "packageversion" (StringConfig version) 	-getVersionString :: IO String-getVersionString = do+getChangelogVersion :: IO String+getChangelogVersion = do 	changelog <- readFile "CHANGELOG" 	let verline = head $ lines changelog 	return $ middle (words verline !! 1)@@ -97,7 +120,7 @@ {- Set up cabal file with version. -} cabalSetup :: IO () cabalSetup = do-	version <- getVersionString+	version <- getChangelogVersion 	cabal <- readFile cabalfile 	writeFile tmpcabalfile $ unlines $  		map (setfield "Version" version) $
+ Build/Configure.o view

binary file changed (absent → 49700 bytes)

+ Build/DesktopFile.hs view
@@ -0,0 +1,90 @@+{- Generating and installing a desktop menu entry file+ - and a desktop autostart file. (And OSX equivilants.)+ -+ - Copyright 2012 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++{-# LANGUAGE CPP #-}++module Build.DesktopFile where++import Utility.Exception+import Utility.FreeDesktop+import Utility.Path+import Utility.Monad+import Locations.UserConfig+import Utility.OSX+import Assistant.Install.AutoStart++import Control.Applicative+import System.Directory+import System.Environment+import System.Posix.User+import System.Posix.Files+import System.FilePath+import Data.Maybe++{- The command can be either just "git-annex", or the full path to use+ - to run it. -}+desktop :: FilePath -> DesktopEntry+desktop command = genDesktopEntry+	"Git Annex"+	"Track and sync the files in your Git Annex"+	False+	(command ++ " webapp")+	["Network", "FileTransfer"]++autostart :: FilePath -> DesktopEntry+autostart command = genDesktopEntry+	"Git Annex Assistant"+	"Autostart"+	False+	(command ++ " assistant --autostart")+	[]++systemwideInstall :: IO Bool+systemwideInstall = isroot <||> destdirset+  where+	isroot = do+		uid <- fromIntegral <$> getRealUserID+		return $ uid == (0 :: Int)+	destdirset = isJust <$> catchMaybeIO (getEnv "DESTDIR")++inDestDir :: FilePath -> IO FilePath+inDestDir f = do+	destdir <- catchDefaultIO "" (getEnv "DESTDIR")+	return $ destdir ++ "/" ++ f++writeFDODesktop :: FilePath -> IO ()+writeFDODesktop command = do+	datadir <- ifM systemwideInstall ( return systemDataDir, userDataDir )+	writeDesktopMenuFile (desktop command) +		=<< inDestDir (desktopMenuFilePath "git-annex" datadir)++	configdir <- ifM systemwideInstall ( return systemConfigDir, userConfigDir )+	installAutoStart command +		=<< inDestDir (autoStartPath "git-annex" configdir)++writeOSXDesktop :: FilePath -> IO ()+writeOSXDesktop command = do+	installAutoStart command =<< inDestDir =<< ifM systemwideInstall+		( return $ systemAutoStart osxAutoStartLabel+		, userAutoStart osxAutoStartLabel+		)++install :: FilePath -> IO ()+install command = do+#ifdef darwin_HOST_OS+	writeOSXDesktop command+#else+	writeFDODesktop command+#endif+	ifM systemwideInstall+		( return ()+		, do+			programfile <- inDestDir =<< programFile+			createDirectoryIfMissing True (parentDir programfile)+			writeFile programfile command+		)
+ Build/EvilSplicer.hs view
@@ -0,0 +1,531 @@+{- Expands template haskell splices+ -+ - First, the code must be built with a ghc that supports TH,+ - and the splices dumped to a log. For example:+ -   cabal build --ghc-options=-ddump-splices 2>&1 | tee log+ -+ - Along with the log, a headers file may also be provided, containing+ - additional imports needed by the template haskell code.+ -+ - This program will parse the log, and expand all splices therein,+ - writing files to the specified destdir (which can be "." to modify+ - the source tree directly). They can then be built a second+ - time, with a ghc that does not support TH.+ -+ - Note that template haskell code may refer to symbols that are not+ - exported by the library that defines the TH code. In this case,+ - the library has to be modifed to export those symbols.+ -+ - There can also be other problems with the generated code; it may+ - need modifications to compile.+ -+ -+ - Copyright 2013 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Main where++import Text.Parsec+import Text.Parsec.String+import Control.Applicative ((<$>))+import Data.Either+import Data.List+import Data.String.Utils+import Data.Char+import System.Environment+import System.FilePath+import System.Directory+import Control.Monad++import Utility.Monad+import Utility.Misc+import Utility.Exception+import Utility.Path++data Coord = Coord+	{ coordLine :: Int+	, coordColumn :: Int+	}+	deriving (Read, Show)++offsetCoord :: Coord -> Coord -> Coord+offsetCoord a b = Coord+	(coordLine a - coordLine b)+	(coordColumn a - coordColumn b)++data SpliceType = SpliceExpression | SpliceDeclaration+	deriving (Read, Show, Eq)++data Splice = Splice+	{ splicedFile :: FilePath+	, spliceStart :: Coord+	, spliceEnd :: Coord+	, splicedExpression :: String+	, splicedCode :: String+	, spliceType :: SpliceType+	}+	deriving (Read, Show)++isExpressionSplice :: Splice -> Bool+isExpressionSplice s = spliceType s == SpliceExpression++number :: Parser Int+number = read <$> many1 digit++{- A pair of Coords is written in one of three ways:+ - "95:21-73", "1:1", or "(92,25)-(94,2)"+ -}+coordsParser :: Parser (Coord, Coord)+coordsParser = (try singleline <|> try weird <|> multiline) <?> "Coords"+  where+  	singleline = do+		line <- number+		char ':'+		startcol <- number+		char '-'+		endcol <- number+		return $ (Coord line startcol, Coord line endcol)++	weird = do+		line <- number+		char ':'+		col <- number+		return $ (Coord line col, Coord line col)++	multiline = do+		start <- fromparens+		char '-'+		end <- fromparens+		return $ (start, end)++	fromparens = between (char '(') (char ')') $ do+		line <- number+		char ','+		col <- number+		return $ Coord line col++indent :: Parser String+indent = many1 $ char ' '++restOfLine :: Parser String+restOfLine = newline `after` many (noneOf "\n")++indentedLine :: Parser String+indentedLine = indent >> restOfLine++spliceParser :: Parser Splice+spliceParser = do+	file <- many1 (noneOf ":\n")+	char ':'+	(start, end) <- coordsParser+	string ": Splicing "+	splicetype <- tosplicetype+		<$> (string "expression" <|> string "declarations")+	newline++	getthline <- expressionextractor+	expression <- unlines <$> many1 getthline++	indent+	string "======>"	+	newline++	getcodeline <- expressionextractor+	realcoords <- try (Right <$> getrealcoords file) <|> (Left <$> getcodeline)+	codelines <- many getcodeline+	return $ case realcoords of+		Left firstcodeline -> +			Splice file start end expression+				(unlines $ firstcodeline:codelines)+				splicetype+		Right (realstart, realend) ->+			Splice file realstart realend expression+				(unlines codelines)+				splicetype+  where+  	tosplicetype "declarations" = SpliceDeclaration+	tosplicetype "expression" = SpliceExpression+	tosplicetype s = error $ "unknown splice type: " ++ s++	{- All lines of the indented expression start with the same+	 - indent, which is stripped. Any other indentation is preserved. -}+	expressionextractor = do+		i <- lookAhead indent+		return $ try $ do+			string i+			restOfLine+	+	{- When splicing declarations, GHC will output a splice+	 - at 1:1, and then inside the splice code block,+	 - the first line will give the actual coordinates of the+	 - line that was spliced. -}+	getrealcoords file = do+		indent+		string file+		char ':'+		char '\n' `after` coordsParser++{- Extracts the splices, ignoring the rest of the compiler output. -}+splicesExtractor :: Parser [Splice]+splicesExtractor = rights <$> many extract+  where+  	extract = try (Right <$> spliceParser) <|> (Left <$> compilerJunkLine)+	compilerJunkLine = restOfLine++{- Modifies the source file, expanding the splices, which all must+ - have the same splicedFile. Writes the new file to the destdir.+ -+ - Each splice's Coords refer to the original position in the file,+ - and not to its position after any previous splices may have inserted+ - or removed lines.+ -+ - To deal with this complication, the file is broken into logical lines+ - (which can contain any String, including a multiline or empty string).+ - Each splice is assumed to be on its own block of lines; two+ - splices on the same line is not currently supported.+ - This means that a splice can modify the logical lines within its block+ - as it likes, without interfering with the Coords of other splices.+ -+ - As well as expanding splices, this can add a block of imports to the+ - file. These are put right before the first line in the file that+ - starts with "import "+ -}+applySplices :: FilePath -> Maybe String -> [Splice] -> IO ()+applySplices destdir imports splices@(first:_) = do+	let f = splicedFile first+	let dest = (destdir </> f)+	lls <- map (++ "\n") . lines <$> readFileStrict f+	createDirectoryIfMissing True (parentDir dest)+	let newcontent = concat $ addimports $ expand lls splices+	oldcontent <- catchMaybeIO $ readFileStrict dest+	when (oldcontent /= Just newcontent) $ do+		putStrLn $ "splicing " ++ f+		writeFile dest newcontent+  where+  	expand lls [] = lls+  	expand lls (s:rest)+		| isExpressionSplice s = expand (expandExpressionSplice s lls) rest+		| otherwise = expand (expandDeclarationSplice s lls) rest++	addimports lls = case imports of+		Nothing -> lls+		Just v ->+			let (start, end) = break ("import " `isPrefixOf`) lls+			in if null end+				then start+				else concat+					[ start+					, [v]+					, end+					]++{- Declaration splices are expanded to replace their whole line. -}+expandDeclarationSplice :: Splice -> [String] -> [String]+expandDeclarationSplice s lls = concat [before, [splice], end]+  where+	cs = spliceStart s+	ce = spliceEnd s++	(before, rest) = splitAt (coordLine cs - 1) lls+	(_oldlines, end) = splitAt (1 + coordLine (offsetCoord ce cs)) rest+	splice = mangleCode $ splicedCode s++{- Expression splices are expanded within their line. -}+expandExpressionSplice :: Splice -> [String] -> [String]+expandExpressionSplice s lls = concat [before, spliced:padding, end]+  where+	cs = spliceStart s+	ce = spliceEnd s++	(before, rest) = splitAt (coordLine cs - 1) lls+	(oldlines, end) = splitAt (1 + coordLine (offsetCoord ce cs)) rest+	(splicestart, padding, spliceend) = case map expandtabs oldlines of+		ss:r+			| null r -> (ss, [], ss)+			| otherwise -> (ss, take (length r) (repeat []), last r)+		_ -> ([], [], [])+	spliced = concat+		[ joinsplice $ deqqstart $ take (coordColumn cs - 1) splicestart+		, addindent (findindent splicestart) (mangleCode $ splicedCode s)+		, deqqend $ drop (coordColumn ce) spliceend+		]++	{- coordinates assume tabs are expanded to 8 spaces -}+	expandtabs = replace "\t" (take 8 $ repeat ' ')++	{- splicing leaves $() quasiquote behind; remove it -}+	deqqstart s = case reverse s of+		('(':'$':rest) -> reverse rest+		_ -> s+	deqqend (')':s) = s+	deqqend s = s++	{- Prepare the code that comes just before the splice so+	 - the splice will combine with it appropriately. -}+	joinsplice s+		-- all indentation? Skip it, we'll use the splice's indentation+		| all isSpace s = ""+		-- function definition needs no preparation+		-- ie: foo = $(splice)+		| "=" `isSuffixOf` s' = s+		-- nor does lambda definition or case expression+		| "->" `isSuffixOf` s' = s+		-- nor does a let .. in declaration+		| "in" `isSuffixOf` s' = s+		-- already have a $ to set off the splice+		-- ie: foo $ $(splice)+		| "$" `isSuffixOf` s' = s+		-- need to add a $ to set off the splice+		-- ie: bar $(splice)+		| otherwise = s ++ " $ "+	  where+	  	s' = filter (not . isSpace) s++	findindent = length . takeWhile isSpace+	addindent n = unlines . map (i ++) . lines+	  where+	  	i = take n $ repeat ' '++{- Tweaks code output by GHC in splices to actually build. Yipes. -}+mangleCode :: String -> String+mangleCode = declaration_parens+	. case_layout+	. case_layout_multiline+	. remove_declaration_splices+	. yesod_url_render_hack+	. yesod_static_route_render_hack+	. nested_instances +	. collapse_multiline_strings+	. remove_package_version+	. emptylambda+  where+  	{- For some reason, GHC sometimes doesn't like the multiline+	 - strings it creates. It seems to get hung up on \{ at the+	 - start of a new line sometimes, wanting it to not be escaped.+	 -+	 - To work around what is likely a GHC bug, just collapse+	 - multiline strings. -}+	collapse_multiline_strings = parsecAndReplace $ do+		string "\\\n"+		many1 $ oneOf " \t"+		string "\\"+		return ""++	{- GHC outputs splices using explicit braces rather than layout.+	 - For a case expression, it does something weird:+	 -+	 - case foo of {+	 -   xxx -> blah+	 -   yyy -> blah };+	 -+	 - This is not legal Haskell; the statements in the case must be+	 - separated by ';'+	 -+	 - To fix, we could just put a semicolon at the start of every line+	 - containing " -> " ... Except that lambdas also contain that.+	 - But we can get around that: GHC outputs lambas like this:+	 -+	 - \ foo+	 -   -> bar+	 -+	 - Or like this:+	 -+	 - \ foo -> bar+	 -+	 - So, we can put the semicolon at the start of every line+	 - containing " -> " unless there's a "\ " first, or it's+	 - all whitespace up until it.+	 -}+	case_layout = parsecAndReplace $ do+		newline+		indent <- many1 $ char ' '+		prefix <- manyTill (noneOf "\n") (try (string "-> "))+		if length prefix > 10+			then unexpected "too long a prefix"+			else if "\\ " `isInfixOf` prefix+				then unexpected "lambda expression"+				else if null prefix+					then unexpected "second line of lambda"+					else return $ "\n" ++ indent ++ "; " ++ prefix ++ " -> "+	{- Sometimes cases themselves span multiple lines:+	 -+	 - Nothing+	 -   -> foo+	 -}+	case_layout_multiline = parsecAndReplace $ do+		newline+		indent <- many1 $ char ' '+		firstline <- manyTill (noneOf "\n") newline++		string indent+		indent2 <- many1 $ char ' '+		string "-> "+		if "\\ " `isInfixOf` firstline+			then unexpected "lambda expression"+			else return $ "\n" ++ indent ++ "; " ++ firstline ++ "\n"+				++ indent ++ indent2 ++ "-> "++	{- (foo, \ -> bar) is not valid haskell, GHC.+	 - Change to (foo, bar)+	 -+	 - (Does this ever happen outside a tuple? Only saw+	 - it inside them..+	 -}+	emptylambda = replace ", \\ -> " ", "++	{- GHC may output this:+	 -+	 - instance RenderRoute WebApp where+	 -   data instance Route WebApp+	 -        ^^^^^^^^+	 - The marked word should not be there.+	 -+	 - FIXME: This is a yesod-specific hack, it should look for the+	 - outer instance.+	 -}+	nested_instances = replace "  data instance Route" "  data Route" ++	{- GHC does not properly parenthesise generated data type+	 - declarations. -}+	declaration_parens = replace "StaticR Route Static" "StaticR (Route Static)"++	{- GHC may add full package and version qualifications for+	 - symbols from unimported modules. We don't want these.+	 -+	 - Examples:+	 -   "blaze-html-0.4.3.1:Text.Blaze.Internal.preEscapedText" +	 -   "ghc-prim:GHC.Types.:"+	 -}+	remove_package_version = parsecAndReplace $+		mangleSymbol <$> qualifiedSymbol++	mangleSymbol "GHC.Types." = ""+	mangleSymbol "GHC.Tuple." = ""+	mangleSymbol s = s++	qualifiedSymbol :: Parser String+	qualifiedSymbol = do+		s <- token+		char ':'+		if length s < 5+			then unexpected "too short to be a namespace"+			else do+				token++	token :: Parser String+	token = do+		t <- satisfy isLetter+		oken <- many $ satisfy isAlphaNum <|> oneOf "-.'"+		return $ t:oken++{- This works around a problem in the expanded template haskell for Yesod's+ - static site route rendering.+ -+ - renderRoute (StaticR sub_a1nUH)+ -   = \ (a_a1nUI, b_a1nUJ)+ -       -> (((pack "static") : a_a1nUI), b_a1nUJ)+ -       (renderRoute sub_a1nUH)+ -+ - That is missing parens around the lambda expression (which + - is supposed to be applied to renderRoute). Add those parens.+ -}+yesod_static_route_render_hack :: String -> String+yesod_static_route_render_hack = parsecAndReplace $ do+	def <- string "renderRoute (StaticR sub_a1nUH)"+	whitespace+	string "= \\ ("+	t1 <- token+	string ", "+	t2 <- token+	string ")"+	whitespace+	f <- string "-> (((pack \"static\") : "+	string t1+	string "), "+	string t2+	string ")"+	return $ concat+		[ def+		, " = (\\ (", t1, ",", t2, ") "+		, f, t1, "), ", t2, "))"+		]+  where+	whitespace :: Parser String+	whitespace = many $ oneOf " \t\r\n"++	token :: Parser String+	token = many1 $ satisfy isAlphaNum <|> oneOf "_"+++{- This works around a problem in the expanded template haskell for Yesod+ - type-safe url rendering.+ -+ - It generates code like this:+ - + -                                  (toHtml+ -                                     (\ u_a2ehE -> urender_a2ehD u_a2ehE []+ -                                        (CloseAlert aid)))));+ -+ - Where urender_a2ehD is the function returned by getUrlRenderParams.+ - But, that function that only takes 2 params, not 3.+ - And toHtml doesn't take a parameter at all!+ - + - So, this modifes the code, to look like this:+ - + -                                  (toHtml+ -                                     (flip urender_a2ehD []+ -                                        (CloseAlert aid)))));+ - + - FIXME: Investigate and fix this properly.+ -}+yesod_url_render_hack :: String -> String+yesod_url_render_hack = parsecAndReplace $ do+	string "(toHtml"+	whitespace+	string "(\\"+	whitespace+	token+	whitespace+	string "->"+	whitespace+	renderer <- token+	whitespace+	token+	whitespace+	return $ "(toHtml (flip " ++ renderer ++ " "+  where+	whitespace :: Parser String+	whitespace = many $ oneOf " \t\r\n"++	token :: Parser String+	token = many1 $ satisfy isAlphaNum <|> oneOf "_"++{- Given a Parser that finds strings it wants to modify,+ - and returns the modified string, does a mass + - find and replace throughout the input string.+ - Rather slow, but crazy powerful. -}+parsecAndReplace :: Parser String -> String -> String+parsecAndReplace p s = case parse find "" s of+	Left e -> s+	Right l -> concatMap (either (\c -> [c]) id) l+  where+  	find :: Parser [Either Char String]+	find = many $ try (Right <$> p) <|> (Left <$> anyChar)++main :: IO ()+main = go =<< getArgs+  where+	go (destdir:log:header:[]) = run destdir log (Just header)+	go (destdir:log:[]) = run destdir log Nothing+  	go _ = error "usage: EvilSplicer destdir logfile [headerfile]"++	run destdir log mheader = do+		r <- parseFromFile splicesExtractor log+		case r of+			Left e -> error $ show e+			Right splices -> do+				let groups = groupBy (\a b -> splicedFile a == splicedFile b) splices+				imports <- maybe (return Nothing) (catchMaybeIO . readFile) mheader+				mapM_ (applySplices destdir imports) groups
+ Build/EvilSplicer.o view

binary file changed (absent → 157660 bytes)

Build/InstallDesktopFile.hs view
@@ -8,86 +8,9 @@  {-# LANGUAGE CPP #-} -module Build.InstallDesktopFile where--import Utility.Exception-import Utility.FreeDesktop-import Utility.Path-import Utility.Monad-import Locations.UserConfig-import Utility.OSX-import Assistant.Install.AutoStart--import Control.Applicative-import System.Directory-import System.Environment-import System.Posix.User-import System.Posix.Files-import System.FilePath-import Data.Maybe--{- The command can be either just "git-annex", or the full path to use- - to run it. -}-desktop :: FilePath -> DesktopEntry-desktop command = genDesktopEntry-	"Git Annex"-	"Track and sync the files in your Git Annex"-	False-	(command ++ " webapp")-	["Network", "FileTransfer"]--autostart :: FilePath -> DesktopEntry-autostart command = genDesktopEntry-	"Git Annex Assistant"-	"Autostart"-	False-	(command ++ " assistant --autostart")-	[]--systemwideInstall :: IO Bool-systemwideInstall = isroot <||> destdirset-  where-	isroot = do-		uid <- fromIntegral <$> getRealUserID-		return $ uid == (0 :: Int)-	destdirset = isJust <$> catchMaybeIO (getEnv "DESTDIR")--inDestDir :: FilePath -> IO FilePath-inDestDir f = do-	destdir <- catchDefaultIO "" (getEnv "DESTDIR")-	return $ destdir ++ "/" ++ f--writeFDODesktop :: FilePath -> IO ()-writeFDODesktop command = do-	datadir <- ifM systemwideInstall ( return systemDataDir, userDataDir )-	writeDesktopMenuFile (desktop command) -		=<< inDestDir (desktopMenuFilePath "git-annex" datadir)--	configdir <- ifM systemwideInstall ( return systemConfigDir, userConfigDir )-	installAutoStart command -		=<< inDestDir (autoStartPath "git-annex" configdir)--writeOSXDesktop :: FilePath -> IO ()-writeOSXDesktop command = do-	installAutoStart command =<< inDestDir =<< ifM systemwideInstall-		( return $ systemAutoStart osxAutoStartLabel-		, userAutoStart osxAutoStartLabel-		)+module Main where -install :: FilePath -> IO ()-install command = do-#ifdef darwin_HOST_OS-	writeOSXDesktop command-#else-	writeFDODesktop command-#endif-	ifM systemwideInstall-		( return ()-		, do-			programfile <- inDestDir =<< programFile-			createDirectoryIfMissing True (parentDir programfile)-			writeFile programfile command-		)+import Build.InstallDesktopFile  main :: IO () main = getArgs >>= go
+ Build/InstallDesktopFile.o view

binary file changed (absent → 17560 bytes)

Build/OSXMkLibs.hs view
@@ -5,7 +5,7 @@  - Licensed under the GNU GPL version 3 or higher.  -} -module Build.OSXMkLibs where+module Main where  import Control.Applicative import System.Environment
Build/Standalone.hs view
@@ -7,7 +7,7 @@  {-# LANGUAGE CPP #-} -module Build.Standalone where+module Main where  import Control.Applicative import Control.Monad.IfElse
+ Build/TestConfig.o view

binary file changed (absent → 32380 bytes)

CHANGELOG view
@@ -1,3 +1,50 @@+git-annex (4.20130417) unstable; urgency=low++  * initremote: Generates encryption keys with high quality entropy.+    This can be disabled using --fast to get the old behavior.+    The assistant still uses low-quality entropy when creating encrypted+    remotes, to avoid delays. (Thanks, guilhem for the patch.)+  * Bugfix: Direct mode no longer repeatedly checksums duplicated files.+  * assistant: Work around horrible, terrible, very bad behavior of+    gnome-keyring, by not storing special-purpose ssh keys in ~/.ssh/*.pub.+    Apparently gnome-keyring apparently will load and indiscriminately use+    such keys in some cases, even if they are not using any of the standard+    ssh key names. Instead store the keys in ~/.ssh/annex/,+    which gnome-keyring will not check.+  * addurl: Bugfix: Did not properly add file in direct mode.+  * assistant: Bug fix to avoid annexing the files that git uses+    to stand in for symlinks on FAT and other filesystem not supporting+    symlinks.+  * Adjust preferred content expressions so that content in archive+    directories is preferred until it has reached an archive or smallarchive+    repository.+  * webapp: New --listen= option allows running the webapp on one computer+    and connecting to it from another. (Note: Does not yet use HTTPS.)+  * Added annex.web-download-command setting.+  * Added per-remote annex-rsync-transport option. (guilhem again)+  * Ssh connection caching is now also used by rsync special remotes.+    (guilhem yet again)+  * The version number is now derived from git, unless built with+    VERSION_FROM_CHANGELOG.+  * assistant: Stop any transfers the assistant initiated on shutdown.+  * assistant: Added sequence numbers to XMPP git push packets. (Not yet used.)+  * addurl: Register transfer so the webapp can see it.+  * addurl: Automatically retry downloads that fail, as long as some+    additional content was downloaded.+  * webapp: Much improved progress bar display for downloads from encrypted+    remotes.+  * Avoid using runghc, as that needs ghci.+  * webapp: When a repository's group is changed, rescan for transfers.+  * webapp: Added animations.+  * webapp: Include the repository directory in the mangled hostname and+    ssh key name, so that a locked down ssh key for one repository is not+    re-used when setting up additional repositories on the same server.+  * Fall back to internal url downloader when built without curl.+  * fsck: Check content of direct mode files (only when the inode cache+    thinks they are unmodified).++ -- Joey Hess <joeyh@debian.org>  Wed, 17 Apr 2013 09:07:38 -0400+ git-annex (4.20130405) unstable; urgency=low    * Group subcommands into sections in usage. Closes: #703797
Command/Add.hs view
@@ -132,7 +132,7 @@ 	goindirect Nothing _ = failure  	godirect (Just (key, _)) (Just cache) = do-		writeInodeCache key cache+		addInodeCache key cache 		finishIngestDirect key source 		return $ Just key 	godirect _ _ = failure@@ -188,19 +188,29 @@  	return l -{- Note: Several other commands call this, and expect it to - - create the link and add it.- - - - In direct mode, when we have the content of the file, it's left as-is,- - and we just stage a symlink to git.- - - - Otherwise, as long as the filesystem supports symlinks, we use+{- Creates the symlink to the annexed content, and stages it in git.+ -+ - As long as the filesystem supports symlinks, we use  - git add, rather than directly staging the symlink to git.  - Using git add is best because it allows the queuing to work  - and is faster (staging the symlink runs hash-object commands each time).  - Also, using git add allows it to skip gitignored files, unless forced  - to include them.  -}+addLink :: FilePath -> Key -> Bool -> Annex ()+addLink file key hascontent = ifM (coreSymlinks <$> Annex.getGitConfig)+	( do+		_ <- link file key hascontent+		params <- ifM (Annex.getState Annex.force)+			( return [Param "-f"]+			, return []+			)+		Annex.Queue.addCommand "add" (params++[Param "--"]) [file]+	, do+		l <- link file key hascontent+		addAnnexLink l file+	)+ cleanup :: FilePath -> Key -> Bool -> CommandCleanup cleanup file key hascontent = do 	when hascontent $@@ -209,17 +219,6 @@ 		( do 			l <- inRepo $ gitAnnexLink file key 			stageSymlink file =<< hashSymlink l-		, ifM (coreSymlinks <$> Annex.getGitConfig)-			( do-				_ <- link file key hascontent-				params <- ifM (Annex.getState Annex.force)-					( return [Param "-f"]-					, return []-					)-				Annex.Queue.addCommand "add" (params++[Param "--"]) [file]-			, do-				l <- link file key hascontent-				addAnnexLink l file-			)+		, addLink file key hascontent 		) 	return True
Command/AddUnused.hs view
@@ -9,6 +9,7 @@  import Common.Annex import Logs.Unused+import Logs.Location import Command import qualified Command.Add import Types.Key@@ -26,7 +27,10 @@ 	(performOther "tmp")  perform :: Key -> CommandPerform-perform key = next $ Command.Add.cleanup file key True+perform key = next $ do+	logStatus key InfoPresent+	Command.Add.addLink file key False+	return True   where 	file = "unused." ++ key2file key
Command/AddUrl.hs view
@@ -14,6 +14,7 @@ import Backend import qualified Command.Add import qualified Annex+import qualified Annex.Queue import qualified Backend.URL import qualified Utility.Url as Url import Annex.Content@@ -23,6 +24,9 @@ import Types.KeySource import Config import Annex.Content.Direct+import Logs.Location+import qualified Logs.Transfer as Transfer+import Utility.Daemon (checkDaemon)  def :: [Command] def = [notBareRepo $ withOptions [fileOption, pathdepthOption, relaxedOption] $@@ -79,10 +83,9 @@ download :: String -> FilePath -> CommandPerform download url file = do 	showAction $ "downloading " ++ url ++ " "-	let dummykey = Backend.URL.fromUrl url Nothing+	dummykey <- genkey 	tmp <- fromRepo $ gitAnnexTmpLocation dummykey-	liftIO $ createDirectoryIfMissing True (parentDir tmp)-	stopUnless (downloadUrl [url] tmp) $ do+	stopUnless (runtransfer dummykey tmp) $ do 		backend <- chooseBackend file 		let source = KeySource 			{ keyFilename = file@@ -92,13 +95,44 @@ 		k <- genKey source backend 		case k of 			Nothing -> stop-			Just (key, _) -> do-				whenM isDirect $-					void $ addAssociatedFile key file-				moveAnnex key tmp-				setUrlPresent key url-				next $ Command.Add.cleanup file key True+			Just (key, _) -> next $ cleanup url file key (Just tmp)+  where+	{- Generate a dummy key to use for this download, before we can+	 - examine the file and find its real key. This allows resuming+	 - downloads, as the dummy key for a given url is stable.+	 -+	 - If the assistant is running, actually hits the url here,+	 - to get the size, so it can display a pretty progress bar.+	 -}+	genkey = do+		pidfile <- fromRepo gitAnnexPidFile+		size <- ifM (liftIO $ isJust <$> checkDaemon pidfile)+			( do+				headers <- getHttpHeaders+				liftIO $ snd <$> Url.exists url headers+			, return Nothing+			)+		return $ Backend.URL.fromUrl url size+  	runtransfer dummykey tmp = +		Transfer.download webUUID dummykey (Just file) Transfer.forwardRetry $ const $ do+			liftIO $ createDirectoryIfMissing True (parentDir tmp)+			downloadUrl [url] tmp+		 +cleanup :: String -> FilePath -> Key -> Maybe FilePath -> CommandCleanup+cleanup url file key mtmp = do+	when (isJust mtmp) $+		logStatus key InfoPresent+	setUrlPresent key url+	Command.Add.addLink file key False+	whenM isDirect $ do+		void $ addAssociatedFile key file+		{- For moveAnnex to work in direct mode, the symlink+		 - must already exist, so flush the queue. -}+		Annex.Queue.flush+	maybe noop (moveAnnex key) mtmp+	return True+ nodownload :: Bool -> String -> FilePath -> CommandPerform nodownload relaxed url file = do 	headers <- getHttpHeaders@@ -108,10 +142,7 @@ 	if exists 		then do 			let key = Backend.URL.fromUrl url size-			whenM isDirect $-				void $ addAssociatedFile key file-			setUrlPresent key url-			next $ Command.Add.cleanup file key False+			next $ cleanup url file key Nothing 		else do 			warning $ "unable to access url: " ++ url 			stop
Command/Fsck.hs view
@@ -112,7 +112,7 @@ 	, verifyLocationLog key file 	, verifyDirectMapping key file 	, checkKeySize key-	, checkBackend backend key+	, checkBackend backend key (Just file) 	, checkKeyNumCopies key file numcopies 	] @@ -150,9 +150,10 @@ 			( return True 			, ifM (Annex.getState Annex.fast) 				( return False-				, Remote.retrieveKeyFile remote key Nothing tmp+				, Remote.retrieveKeyFile remote key Nothing tmp dummymeter 				) 			)+	dummymeter _ = noop  {- To fsck a bare repository, fsck each key in the location log. -} withBarePresentKeys :: (Key -> CommandStart) -> CommandSeek@@ -176,7 +177,7 @@ performBare key backend = check 	[ verifyLocationLog key (key2file key) 	, checkKeySize key-	, checkBackend backend key+	, checkBackend backend key Nothing 	]  check :: [Annex Bool] -> Annex Bool@@ -320,17 +321,19 @@  - because modification of direct mode files is allowed. It's still done  - if the file does not appear modified, to catch disk corruption, etc.  -}-checkBackend :: Backend -> Key -> Annex Bool-checkBackend backend key = do-	file <- calcRepo $ gitAnnexLocation key-	ifM isDirect-		( ifM (goodContent key file)-			( checkBackendOr' (badContentDirect file) backend key file-				(goodContent key file)-			, return True-			)-		, checkBackendOr badContent backend key file+checkBackend :: Backend -> Key -> Maybe FilePath -> Annex Bool+checkBackend backend key mfile = go =<< isDirect+  where+  	go False = do+		content <- calcRepo $ gitAnnexLocation key+		checkBackendOr badContent backend key content+	go True = maybe nocheck checkdirect mfile+	checkdirect file = ifM (goodContent key file)+		( checkBackendOr' (badContentDirect file) backend key file+			(goodContent key file)+		, nocheck 		)+	nocheck = return True  checkBackendRemote :: Backend -> Key -> Remote -> Maybe FilePath -> Annex Bool checkBackendRemote backend key remote = maybe (return True) go
Command/Get.hs view
@@ -69,7 +69,7 @@ 			either (const False) id <$> Remote.hasKey r key 		| otherwise = return True 	docopy r continue = do-		ok <- download (Remote.uuid r) key (Just file) noRetry $ do+		ok <- download (Remote.uuid r) key (Just file) noRetry $ \p -> do 			showAction $ "from " ++ Remote.name r-			Remote.retrieveKeyFile r key (Just file) dest+			Remote.retrieveKeyFile r key (Just file) dest p 		if ok then return ok else continue
Command/Migrate.hs view
@@ -55,7 +55,7 @@  - be other files still pointing at that key. -} perform :: FilePath -> Key -> Backend -> Backend -> CommandPerform perform file oldkey oldbackend newbackend = do-	ifM (Command.Fsck.checkBackend oldbackend oldkey)+	ifM (Command.Fsck.checkBackend oldbackend oldkey (Just file)) 		( maybe stop go =<< genkey 		, stop 		)
Command/Move.hs view
@@ -144,9 +144,9 @@ 		, handle move =<< go 		)   where-	go = download (Remote.uuid src) key (Just file) noRetry $ do+	go = download (Remote.uuid src) key (Just file) noRetry $ \p -> do 		showAction $ "from " ++ Remote.name src-		getViaTmp key $ Remote.retrieveKeyFile src key (Just file)+		getViaTmp key $ \t -> Remote.retrieveKeyFile src key (Just file) t p 	handle _ False = stop -- failed 	handle False True = next $ return True -- copy complete 	handle True True = do -- finish moving
Command/ReKey.hs view
@@ -14,6 +14,7 @@ import Annex.Content import qualified Command.Add import Logs.Web+import Logs.Location import Config import Utility.CopyFile @@ -70,4 +71,6 @@  	-- Update symlink to use the new key. 	liftIO $ removeFile file-	Command.Add.cleanup file newkey True+	Command.Add.addLink file newkey True+	logStatus newkey InfoPresent+	return True
Command/Status.hs view
@@ -5,7 +5,7 @@  - Licensed under the GNU GPL version 3 or higher.  -} -{-# LANGUAGE PackageImports, BangPatterns #-}+{-# LANGUAGE BangPatterns #-}  module Command.Status where
Command/TransferKey.hs view
@@ -52,8 +52,8 @@  fromPerform :: Remote -> Key -> AssociatedFile -> CommandPerform fromPerform remote key file = go $-	download (uuid remote) key file forwardRetry $-		getViaTmp key $ Remote.retrieveKeyFile remote key file+	download (uuid remote) key file forwardRetry $ \p ->+		getViaTmp key $ \t -> Remote.retrieveKeyFile remote key file t p  go :: Annex Bool -> CommandPerform go a = ifM a ( liftIO exitSuccess,  liftIO exitFailure)
Command/TransferKeys.hs view
@@ -59,8 +59,8 @@ 				when ok $ 					Remote.logStatus remote key InfoPresent 				return ok-		| otherwise = download (Remote.uuid remote) key file forwardRetry $-			getViaTmp key $ Remote.retrieveKeyFile remote key file+		| otherwise = download (Remote.uuid remote) key file forwardRetry $ \p ->+			getViaTmp key $ \t -> Remote.retrieveKeyFile remote key file t p  runRequests 	:: Handle
Command/Watch.hs view
@@ -31,5 +31,5 @@ start assistant foreground stopdaemon = do 	if stopdaemon 		then stopDaemon-		else startDaemon assistant foreground Nothing -- does not return+		else startDaemon assistant foreground Nothing Nothing -- does not return 	stop
Command/WebApp.hs view
@@ -23,24 +23,33 @@ import qualified Git.CurrentRepo import qualified Annex import Locations.UserConfig+import qualified Option  import System.Posix.Directory import Control.Concurrent import Control.Concurrent.STM import System.Process (env, std_out, std_err)+import Network.Socket (HostName)+import System.Environment  def :: [Command]-def = [noCommit $ noRepo startNoRepo $ dontCheck repoExists $ notBareRepo $+def = [ withOptions [listenOption] $+	noCommit $ noRepo startNoRepo $ dontCheck repoExists $ notBareRepo $ 	command "webapp" paramNothing seek SectionCommon "launch webapp"] +listenOption :: Option+listenOption = Option.field [] "listen" paramAddress+	"accept connections to this address"+ seek :: [CommandSeek]-seek = [withNothing start]+seek = [withField listenOption return $ \listenhost ->+	withNothing $ start listenhost] -start :: CommandStart+start :: Maybe HostName -> CommandStart start = start' True -start' :: Bool -> CommandStart-start' allowauto = do+start' :: Bool -> Maybe HostName -> CommandStart+start' allowauto listenhost = do 	liftIO $ ensureInstalled 	ifM isInitialized ( go , auto ) 	stop@@ -49,10 +58,14 @@ 		browser <- fromRepo webBrowser 		f <- liftIO . absPath =<< fromRepo gitAnnexHtmlShim 		ifM (checkpid <&&> checkshim f)-			( liftIO $ openBrowser browser f Nothing Nothing-			, startDaemon True True $ Just $ -				\origout origerr _url htmlshim ->-					openBrowser browser htmlshim origout origerr+			( if isJust listenhost+				then error "The assistant is already running, so --listen cannot be used."+				else liftIO $ openBrowser browser f Nothing Nothing+			, startDaemon True True listenhost $ Just $ +				\origout origerr url htmlshim ->+					if isJust listenhost+						then maybe noop (`hPutStrLn` url) origout+						else openBrowser browser htmlshim origout origerr 			) 	auto 		| allowauto = liftIO startNoRepo@@ -68,13 +81,20 @@  - the autostart file. If not, it's our first time being run! -} startNoRepo :: IO () startNoRepo = do+	-- FIXME should be able to reuse regular getopt, but +	-- it currently runs in the Annex monad.+	args <- getArgs+	let listenhost = headMaybe $ map (snd . separate (== '=')) $ +		filter ("--listen=" `isPrefixOf`) args+ 	dirs <- liftIO $ filterM doesDirectoryExist =<< readAutoStartFile 	case dirs of-		[] -> firstRun+		[] -> firstRun listenhost 		(d:_) -> do 			changeWorkingDirectory d 			state <- Annex.new =<< Git.CurrentRepo.get-			void $ Annex.eval state $ doCommand $ start' False+			void $ Annex.eval state $ doCommand $+				start' False listenhost  {- Run the webapp without a repository, which prompts the user, makes one,  - changes to it, starts the regular assistant, and redirects the@@ -89,8 +109,8 @@  - Note that it's important that mainthread never terminates! Much  - of this complication is due to needing to keep the mainthread running.  -}-firstRun :: IO ()-firstRun = do+firstRun :: Maybe HostName -> IO ()+firstRun listenhost = do 	{- Without a repository, we cannot have an Annex monad, so cannot 	 - get a ThreadState. Using undefined is only safe because the 	 - webapp checks its noAnnex field before accessing the@@ -104,7 +124,7 @@ 	let callback a = Just $ a v 	runAssistant d $ do 		startNamedThread urlrenderer $-			webAppThread d urlrenderer True +			webAppThread d urlrenderer True listenhost 				(callback signaler) 				(callback mainthread) 		waitNamedThreads@@ -112,15 +132,21 @@ 	signaler v = do 		putMVar v "" 		takeMVar v-	mainthread v _url htmlshim = do-		browser <- maybe Nothing webBrowser <$> Git.Config.global-		openBrowser browser htmlshim Nothing Nothing--		_wait <- takeMVar v--		state <- Annex.new =<< Git.CurrentRepo.get-		Annex.eval state $-			startDaemon True True $ Just $ sendurlback v+	mainthread v url htmlshim+		| isJust listenhost = do+			putStrLn url+			go+		| otherwise = do+			browser <- maybe Nothing webBrowser <$> Git.Config.global+			openBrowser browser htmlshim Nothing Nothing+			go+	  where+		go = do+			_wait <- takeMVar v+			state <- Annex.new =<< Git.CurrentRepo.get+			Annex.eval state $+				startDaemon True True listenhost $ Just $+					sendurlback v 	sendurlback v _origout _origerr url _htmlshim = putMVar v url  openBrowser :: Maybe FilePath -> FilePath -> Maybe Handle -> Maybe Handle -> IO ()
+ Common.o view

binary file changed (absent → 622 bytes)

Crypto.hs view
@@ -67,15 +67,16 @@ cipherMac (Cipher c) = take cipherBeginning c  {- Creates a new Cipher, encrypted to the specified key id. -}-genEncryptedCipher :: String -> IO StorableCipher-genEncryptedCipher keyid = do+genEncryptedCipher :: String -> Bool -> IO StorableCipher+genEncryptedCipher keyid highQuality = do 	ks <- Gpg.findPubKeys keyid-	random <- Gpg.genRandom cipherSize+	random <- Gpg.genRandom highQuality cipherSize 	encryptCipher (Cipher random) ks  {- Creates a new, shared Cipher. -}-genSharedCipher :: IO StorableCipher-genSharedCipher = SharedCipher <$> Gpg.genRandom cipherSize+genSharedCipher :: Bool -> IO StorableCipher+genSharedCipher highQuality =+	SharedCipher <$> Gpg.genRandom highQuality cipherSize  {- Updates an existing Cipher, re-encrypting it to add a keyid. -} updateEncryptedCipher :: String -> StorableCipher -> IO StorableCipher
+ Locations/UserConfig.o view

binary file changed (absent → 12856 bytes)

Logs/Group.hs view
@@ -44,7 +44,12 @@ 		showLog (unwords . S.toList) . 			changeLog ts uuid (modifier curr) . 				parseLog (Just . S.fromList . words)-	Annex.changeState $ \s -> s { Annex.groupmap = Nothing }+	+	-- The changed group invalidates the preferred content cache.+	Annex.changeState $ \s -> s+		{ Annex.groupmap = Nothing+		, Annex.preferredcontentmap = Nothing+		} groupChange NoUUID _ = error "unknown UUID; cannot modify"  groupSet :: UUID -> S.Set Group -> Annex ()
Logs/Transfer.hs view
@@ -97,8 +97,8 @@ upload :: UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex Bool) -> Annex Bool upload u key = runTransfer (Transfer Upload u key) -download :: UUID -> Key -> AssociatedFile -> RetryDecider -> Annex Bool -> Annex Bool-download u key file shouldretry a = runTransfer (Transfer Download u key) file shouldretry (const a)+download :: UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex Bool) -> Annex Bool+download u key = runTransfer (Transfer Download u key)  {- Runs a transfer action. Creates and locks the lock file while the  - action is running, and stores info in the transfer information
Makefile view
@@ -4,7 +4,7 @@ GHC?=ghc GHCMAKE=$(GHC) $(GHCFLAGS) --make PREFIX=/usr-CABAL?=cabal # set to "runghc Setup.hs" if you lack a cabal program+CABAL?=cabal # set to "./Setup" if you lack a cabal program  # Am I typing :make in vim? Do a fast build. ifdef VIM@@ -16,6 +16,7 @@ 	touch $@  Build/SysConfig.hs: configure.hs Build/TestConfig.hs Build/Configure.hs+	if [ "$(CABAL)" = ./Setup ]; then ghc --make Setup; fi 	$(CABAL) configure  git-annex: Build/SysConfig.hs@@ -26,6 +27,7 @@ 	./Build/mdwn2man git-annex 1 doc/git-annex.mdwn > git-annex.1 git-annex-shell.1: doc/git-annex-shell.mdwn 	./Build/mdwn2man git-annex-shell 1 doc/git-annex-shell.mdwn > git-annex-shell.1+ git-union-merge.1: doc/git-union-merge.mdwn 	./Build/mdwn2man git-union-merge 1 doc/git-union-merge.mdwn > git-union-merge.1 @@ -39,18 +41,18 @@ 		rsync -a --delete html/ $(DESTDIR)$(PREFIX)/share/doc/git-annex/html/; \ 	fi -install: build install-docs+install: build install-docs Build/InstallDesktopFile 	install -d $(DESTDIR)$(PREFIX)/bin 	install git-annex $(DESTDIR)$(PREFIX)/bin 	ln -sf git-annex $(DESTDIR)$(PREFIX)/bin/git-annex-shell-	runghc Build/InstallDesktopFile.hs $(PREFIX)/bin/git-annex || true+	./Build/InstallDesktopFile $(PREFIX)/bin/git-annex || true  test: git-annex 	./git-annex test  # hothasktags chokes on some tempolate haskell etc, so ignore errors tags:-	find . | grep -v /.git/ | grep -v /dist/ | grep -v /doc/ | egrep '\.hs$$' | xargs hothasktags > tags 2>/dev/null+	find . | grep -v /.git/ | grep -v /tmp/ | grep -v /dist/ | grep -v /doc/ | egrep '\.hs$$' | xargs hothasktags > tags 2>/dev/null  # If ikiwiki is available, build static html docs suitable for being # shipped in the software package.@@ -71,8 +73,20 @@  clean: 	rm -rf tmp dist git-annex $(mans) configure  *.tix .hpc \-		doc/.ikiwiki html dist tags Build/SysConfig.hs build-stamp+		doc/.ikiwiki html dist tags Build/SysConfig.hs build-stamp \+		Setup Build/InstallDesktopFile Build/EvilSplicer \+		Build/Standalone Build/OSXMkLibs+	find -name \*.o -or -name \*.hi -exec rm {} \; +Build/InstallDesktopFile: Build/InstallDesktopFile.hs+	$(GHC) --make $@+Build/EvilSplicer: Build/EvilSplicer.hs+	$(GHC) --make $@+Build/Standalone: Build/Standalone.hs Build/SysConfig.hs+	$(GHC) --make $@+Build/OSXMkLibs: Build/OSXMkLibs.hs+	$(GHC) --make $@+ sdist: clean $(mans) 	./Build/make-sdist.sh @@ -81,7 +95,7 @@ 	@cabal upload dist/*.tar.gz  LINUXSTANDALONE_DEST=tmp/git-annex.linux-linuxstandalone:+linuxstandalone: Build/Standalone 	$(MAKE) git-annex  	rm -rf "$(LINUXSTANDALONE_DEST)"@@ -94,7 +108,7 @@ 	ln -sf git-annex "$(LINUXSTANDALONE_DEST)/bin/git-annex-shell" 	zcat standalone/licences.gz > $(LINUXSTANDALONE_DEST)/LICENSE -	runghc Build/Standalone.hs "$(LINUXSTANDALONE_DEST)"+	./Build/Standalone "$(LINUXSTANDALONE_DEST)" 	 	install -d "$(LINUXSTANDALONE_DEST)/git-core" 	(cd "$(shell git --exec-path)" && tar c .) | (cd "$(LINUXSTANDALONE_DEST)"/git-core && tar x)@@ -118,7 +132,7 @@  OSXAPP_DEST=tmp/build-dmg/git-annex.app OSXAPP_BASE=$(OSXAPP_DEST)/Contents/MacOS/bundle-osxapp:+osxapp: Build/Standalone Build/OSXMkLibs 	$(MAKE) git-annex  	rm -rf "$(OSXAPP_DEST)"@@ -132,12 +146,12 @@ 	gzcat standalone/licences.gz > $(OSXAPP_BASE)/LICENSE 	cp $(OSXAPP_BASE)/LICENSE tmp/build-dmg/LICENSE.txt -	runghc Build/Standalone.hs $(OSXAPP_BASE)+	./Build/Standalone $(OSXAPP_BASE)  	(cd "$(shell git --exec-path)" && tar c .) | (cd "$(OSXAPP_BASE)" && tar x) 	install -d "$(OSXAPP_BASE)/templates" -	runghc Build/OSXMkLibs.hs $(OSXAPP_BASE)+	./Build/OSXMkLibs $(OSXAPP_BASE) 	rm -f tmp/git-annex.dmg 	hdiutil create -size 640m -format UDRW -srcfolder tmp/build-dmg \ 		-volname git-annex -o tmp/git-annex.dmg@@ -146,13 +160,31 @@  # Cross compile for Android. # Uses https://github.com/neurocyte/ghc-android-android:-	$(CABAL) configure-# cabal cannot cross compile with custom build type, so workaround-	sed -i 's/Build-type: Custom/Build-type: Simple/' git-annex.cabal-	$$HOME/.ghc/android-14/arm-linux-androideabi-4.7/arm-linux-androideabi/bin/cabal configure -f'Android Assistant -Pairing -Webapp'-	$(MAKE) git-annex-	sed -i 's/Build-type: Simple/Build-type: Custom/' git-annex.cabal+android: Build/EvilSplicer+	echo "Running native build, to get TH splices.."+	if [ ! -e dist/setup/setup ]; then $(CABAL) configure -f"-Production" -O0; fi+	mkdir -p tmp+	if ! $(CABAL) build --ghc-options=-ddump-splices 2> tmp/dump-splices; then tail tmp/dump-splices >&2; exit 1; fi+	echo "Setting up Android build tree.."+	./Build/EvilSplicer tmp/splices tmp/dump-splices standalone/android/evilsplicer-headers.hs+	rsync -az --exclude tmp --exclude dist . tmp/androidtree+# Copy the files with expanded splices to the source tree, but+# only if the existing source file is not newer. (So, if a file+# used to have TH splices but they were removed, it will be newer,+# and not overwritten.)+	cp -uR tmp/splices/* tmp/androidtree+# Some additional dependencies needed by the expanded splices.+	sed -i 's/^  Build-Depends: /  Build-Depends: yesod-routes, yesod-core, shakespeare-css, shakespeare-js, shakespeare, blaze-markup, file-embed, wai-app-static, /' tmp/androidtree/git-annex.cabal+# Avoid warnings due to sometimes unused imports added for the splices.+	sed -i 's/-Wall/-Wall -fno-warn-unused-imports/' tmp/androidtree/git-annex.cabal+# Cabal cannot cross compile with custom build type, so workaround.+	sed -i 's/Build-type: Custom/Build-type: Simple/' tmp/androidtree/git-annex.cabal+	if [ ! -e tmp/androidtree/dist/setup/setup ]; then \+		cd tmp/androidtree; \+		cabal configure; \+		$$HOME/.ghc/android-14/arm-linux-androideabi-4.7/arm-linux-androideabi/bin/cabal configure -f'Android Assistant -Pairing'; \+	fi+	$(MAKE) -C tmp/androidtree git-annex  androidapp: 	$(MAKE) android
Remote/Bup.hs view
@@ -136,8 +136,8 @@ 			encrypt (getGpgOpts r) cipher (feedFile src) $ \h -> 				pipeBup params (Just h) Nothing -retrieve :: BupRepo -> Key -> AssociatedFile -> FilePath -> Annex Bool-retrieve buprepo k _f d = do+retrieve :: BupRepo -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool+retrieve buprepo k _f d _p = do 	let params = bupParams "join" buprepo [Param $ bupRef k] 	liftIO $ catchBoolIO $ do 		tofile <- openFile d WriteMode@@ -146,8 +146,8 @@ retrieveCheap :: BupRepo -> Key -> FilePath -> Annex Bool retrieveCheap _ _ _ = return False -retrieveEncrypted :: BupRepo -> (Cipher, Key) -> Key -> FilePath -> Annex Bool-retrieveEncrypted buprepo (cipher, enck) _ f = liftIO $ catchBoolIO $+retrieveEncrypted :: BupRepo -> (Cipher, Key) -> Key -> FilePath -> MeterUpdate -> Annex Bool+retrieveEncrypted buprepo (cipher, enck) _ f _p = liftIO $ catchBoolIO $ 	withHandle StdoutHandle createProcessSuccess p $ \h -> do 		decrypt cipher (\toh -> L.hPut toh =<< L.hGetContents h) $ 			readBytes $ L.writeFile f
Remote/Directory.hs view
@@ -197,15 +197,15 @@ 		writeFile f s 		void $ tryIO $ preventWrite f -retrieve :: FilePath -> ChunkSize -> Key -> AssociatedFile -> FilePath -> Annex Bool-retrieve d chunksize k _ f = metered Nothing k $ \meterupdate ->+retrieve :: FilePath -> ChunkSize -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool+retrieve d chunksize k _ f p = metered (Just p) k $ \meterupdate -> 	liftIO $ withStoredFiles chunksize d k $ \files -> 		catchBoolIO $ do 			meteredWriteFileChunks meterupdate f files $ L.readFile 			return True -retrieveEncrypted :: FilePath -> ChunkSize -> (Cipher, Key) -> Key -> FilePath -> Annex Bool-retrieveEncrypted d chunksize (cipher, enck) k f = metered Nothing k $ \meterupdate ->+retrieveEncrypted :: FilePath -> ChunkSize -> (Cipher, Key) -> Key -> FilePath -> MeterUpdate -> Annex Bool+retrieveEncrypted d chunksize (cipher, enck) k f p = metered (Just p) k $ \meterupdate -> 	liftIO $ withStoredFiles chunksize d enck $ \files -> 		catchBoolIO $ do 			decrypt cipher (feeder files) $
Remote/Git.hs view
@@ -271,8 +271,10 @@ 		[]  {- Tries to copy a key's content from a remote's annex to a file. -}-copyFromRemote :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool-copyFromRemote r key file dest+copyFromRemote :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool+copyFromRemote r key file dest _p = copyFromRemote' r key file dest+copyFromRemote' :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool+copyFromRemote' r key file dest 	| not $ Git.repoIsUrl (repo r) = guardUsable (repo r) False $ do 		let params = rsyncParams r 		u <- getUUID@@ -338,7 +340,7 @@ 		liftIO $ catchBoolIO $ createSymbolicLink loc file >> return True 	| Git.repoIsSsh (repo r) = 		ifM (Annex.Content.preseedTmp key file)-			( copyFromRemote r key Nothing file+			( copyFromRemote' r key Nothing file 			, return False 			) 	| otherwise = return False@@ -367,7 +369,7 @@ 			( return True 			, do 				ensureInitialized-				download u key file noRetry $+				download u key file noRetry $ const $ 					Annex.Content.saveState True `after` 						Annex.Content.getViaTmpChecked (liftIO checksuccessio) key 							(\d -> rsyncOrCopyFile params object d p)
Remote/Glacier.hs view
@@ -83,31 +83,31 @@ 		]  store :: Remote -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool-store r k _f m+store r k _f p 	| keySize k == Just 0 = do 		warning "Cannot store empty files in Glacier." 		return False 	| otherwise = sendAnnex k (void $ remove r k) $ \src ->-		metered (Just m) k $ \meterupdate ->+		metered (Just p) k $ \meterupdate -> 			storeHelper r k $ streamMeteredFile src meterupdate  storeEncrypted :: Remote -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool-storeEncrypted r (cipher, enck) k m = sendAnnex k (void $ remove r enck) $ \src -> do-	metered (Just m) k $ \meterupdate ->+storeEncrypted r (cipher, enck) k p = sendAnnex k (void $ remove r enck) $ \src -> do+	metered (Just p) k $ \meterupdate -> 		storeHelper r enck $ \h -> 			encrypt (getGpgOpts r) cipher (feedFile src) 				(readBytes $ meteredWrite meterupdate h) -retrieve :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool-retrieve r k _f d = metered Nothing k $ \meterupdate ->+retrieve :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool+retrieve r k _f d p = metered (Just p) k $ \meterupdate -> 	retrieveHelper r k $ 		readBytes $ meteredWriteFile meterupdate d  retrieveCheap :: Remote -> Key -> FilePath -> Annex Bool retrieveCheap _ _ _ = return False -retrieveEncrypted :: Remote -> (Cipher, Key) -> Key -> FilePath -> Annex Bool-retrieveEncrypted r (cipher, enck) k d = metered Nothing k $ \meterupdate ->+retrieveEncrypted :: Remote -> (Cipher, Key) -> Key -> FilePath -> MeterUpdate -> Annex Bool+retrieveEncrypted r (cipher, enck) k d p = metered (Just p) k $ \meterupdate -> 	retrieveHelper r enck $ readBytes $ \b -> 		decrypt cipher (feedBytes b) $ 			readBytes $ meteredWriteFile meterupdate d
Remote/Helper/Encryptable.hs view
@@ -31,15 +31,21 @@ 	(Just "none", Just _) -> cannotchange 	(Just "shared", Just (EncryptedCipher _ _)) -> cannotchange 	(Just _, Just (SharedCipher _)) -> cannotchange-	(Just "shared", Nothing) -> use "encryption setup" $ genSharedCipher-	(Just keyid, Nothing) -> use "encryption setup" $ genEncryptedCipher keyid+	(Just "shared", Nothing) -> use "encryption setup" . genSharedCipher+		=<< highRandomQuality+	(Just keyid, Nothing) -> use "encryption setup" . genEncryptedCipher keyid+		=<< highRandomQuality 	(Just keyid, Just v) -> use "encryption updated" $ updateEncryptedCipher keyid v   where 	cannotchange = error "Cannot change encryption type of existing remote." 	use m a = do 		cipher <- liftIO a 		showNote $ m ++ " " ++ describeCipher cipher-		return $ M.delete "encryption" $ storeCipher c cipher+		return $ M.delete "encryption" $ M.delete "highRandomQuality" $+				storeCipher c cipher+	highRandomQuality = +		(&&) (maybe True ( /= "false") $ M.lookup "highRandomQuality" c)+			<$> fmap not (Annex.getState Annex.fast)  {- Modifies a Remote to support encryption.  -@@ -48,7 +54,7 @@ encryptableRemote 	:: RemoteConfig 	-> ((Cipher, Key) -> Key -> MeterUpdate -> Annex Bool)-	-> ((Cipher, Key) -> Key -> FilePath -> Annex Bool)+	-> ((Cipher, Key) -> Key -> FilePath -> MeterUpdate -> Annex Bool) 	-> Remote 	-> Remote encryptableRemote c storeKeyEncrypted retrieveKeyFileEncrypted r = @@ -64,9 +70,9 @@ 	store k f p = cip k >>= maybe 		(storeKey r k f p) 		(\enck -> storeKeyEncrypted enck k p)-	retrieve k f d = cip k >>= maybe-		(retrieveKeyFile r k f d)-		(\enck -> retrieveKeyFileEncrypted enck k d)+	retrieve k f d p = cip k >>= maybe+		(retrieveKeyFile r k f d p)+		(\enck -> retrieveKeyFileEncrypted enck k d p) 	retrieveCheap k d = cip k >>= maybe 		(retrieveKeyFileCheap r k d) 		(\_ -> return False)
Remote/Helper/Hooks.hs view
@@ -29,7 +29,7 @@   where 	r' = r 		{ storeKey = \k f p -> wrapper $ storeKey r k f p-		, retrieveKeyFile = \k f d -> wrapper $ retrieveKeyFile r k f d+		, retrieveKeyFile = \k f d p -> wrapper $ retrieveKeyFile r k f d p 		, retrieveKeyFileCheap = \k f -> wrapper $ retrieveKeyFileCheap r k f 		, removeKey = \k -> wrapper $ removeKey r k 		, hasKey = \k -> wrapper $ hasKey r k
Remote/Helper/Ssh.hs view
@@ -23,8 +23,9 @@ 	g <- fromRepo id 	let c = extractRemoteGitConfig g (Git.repoDescribe repo) 	let opts = map Param $ remoteAnnexSshOptions c-	params <- sshParams (Git.Url.hostuser repo, Git.Url.port repo) opts-	return $ params ++ sshcmd+	let host = Git.Url.hostuser repo+	params <- sshCachingOptions (host, Git.Url.port repo) opts+	return $ params ++ Param host : sshcmd  {- Generates parameters to run a git-annex-shell command on a remote  - repository. -}
Remote/Hook.hs view
@@ -116,14 +116,14 @@ 			readBytes $ L.writeFile tmp 		runHook h "store" enck (Just tmp) $ return True -retrieve :: String -> Key -> AssociatedFile -> FilePath -> Annex Bool-retrieve h k _f d = runHook h "retrieve" k (Just d) $ return True+retrieve :: String -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool+retrieve h k _f d _p = runHook h "retrieve" k (Just d) $ return True  retrieveCheap :: String -> Key -> FilePath -> Annex Bool retrieveCheap _ _ _ = return False -retrieveEncrypted :: String -> (Cipher, Key) -> Key -> FilePath -> Annex Bool-retrieveEncrypted h (cipher, enck) _ f = withTmp enck $ \tmp ->+retrieveEncrypted :: String -> (Cipher, Key) -> Key -> FilePath -> MeterUpdate -> Annex Bool+retrieveEncrypted h (cipher, enck) _ f _p = withTmp enck $ \tmp -> 	runHook h "retrieve" enck (Just tmp) $ liftIO $ catchBoolIO $ do 		decrypt cipher (feedFile tmp) $ 			readBytes $ L.writeFile f
Remote/Rsync.hs view
@@ -17,6 +17,7 @@ import Config import Config.Cost import Annex.Content+import Annex.Ssh import Remote.Helper.Special import Remote.Helper.Encryptable import Crypto@@ -44,6 +45,9 @@ gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex Remote gen r u c gc = do 	cst <- remoteCost gc expensiveRemoteCost+	(transport, url) <- rsyncTransport+	let o = RsyncOpts url (transport ++ opts) escape+	    islocal = rsyncUrlIsPath $ rsyncUrl o 	return $ encryptableRemote c 		(storeEncrypted o $ getGpgOpts gc) 		(retrieveEncrypted o)@@ -69,9 +73,6 @@ 			, remotetype = remote 			}   where-	o = RsyncOpts url opts escape-	islocal = rsyncUrlIsPath $ rsyncUrl o-	url = fromMaybe (error "missing rsyncurl") $ remoteAnnexRsyncUrl gc 	opts = map Param $ filter safe $ remoteAnnexRsyncOptions gc 	escape = M.lookup "shellescape" c /= Just "no" 	safe opt@@ -81,6 +82,28 @@ 		| opt == "--delete" = False 		| opt == "--delete-excluded" = False 		| otherwise = True+	rawurl = fromMaybe (error "missing rsyncurl") $ remoteAnnexRsyncUrl gc+	(login,resturl) = case separate (=='@') rawurl of+			(h, "") -> (Nothing, h)+			(l, h)  -> (Just l, h)+	loginopt = maybe [] (\l -> ["-l",l]) login+	fromNull as xs | null xs = as+		       | otherwise = xs+	rsyncTransport = if rsyncUrlIsShell rawurl+		then (\rsh -> return (rsyncShell rsh, resturl)) =<<+			case fromNull ["ssh"] (remoteAnnexRsyncTransport gc) of+				"ssh":sshopts -> do+					let (port, sshopts') = sshReadPort sshopts+					    host = takeWhile (/=':') resturl+					-- Connection caching+					(Param "ssh":) <$> sshCachingOptions+						(host, port)+						(map Param $ loginopt ++ sshopts')+				"rsh":rshopts -> return $ map Param $ "rsh" :+					loginopt ++ rshopts+				rsh -> error $ "Unknown Rsync transport: "+					++ unwords rsh+		else return ([], rawurl)  rsyncSetup :: UUID -> RemoteConfig -> Annex RemoteConfig rsyncSetup u c = do@@ -115,20 +138,15 @@ 			readBytes $ L.writeFile tmp 		rsyncSend o p enck True tmp -retrieve :: RsyncOpts -> Key -> AssociatedFile -> FilePath -> Annex Bool-retrieve o k _ f = untilTrue (rsyncUrls o k) $ \u -> rsyncRemote o Nothing-	-- use inplace when retrieving to support resuming-	[ Param "--inplace"-	, Param u-	, Param f-	]+retrieve :: RsyncOpts -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool+retrieve o k _ f p = rsyncRetrieve o k f (Just p)  retrieveCheap :: RsyncOpts -> Key -> FilePath -> Annex Bool-retrieveCheap o k f = ifM (preseedTmp k f) ( retrieve o k undefined f , return False )+retrieveCheap o k f = ifM (preseedTmp k f) ( rsyncRetrieve o k f Nothing , return False ) -retrieveEncrypted :: RsyncOpts -> (Cipher, Key) -> Key -> FilePath -> Annex Bool-retrieveEncrypted o (cipher, enck) _ f = withTmp enck $ \tmp ->-	ifM (retrieve o enck undefined tmp)+retrieveEncrypted :: RsyncOpts -> (Cipher, Key) -> Key -> FilePath -> MeterUpdate -> Annex Bool+retrieveEncrypted o (cipher, enck) _ f p = withTmp enck $ \tmp ->+	ifM (rsyncRetrieve o enck tmp (Just p)) 		( liftIO $ catchBoolIO $ do 			decrypt cipher (feedFile tmp) $ 				readBytes $ L.writeFile f@@ -196,6 +214,15 @@   where 	nuke d = liftIO $ whenM (doesDirectoryExist d) $ 		removeDirectoryRecursive d++rsyncRetrieve :: RsyncOpts -> Key -> FilePath -> Maybe MeterUpdate -> Annex Bool+rsyncRetrieve o k dest callback =+	untilTrue (rsyncUrls o k) $ \u -> rsyncRemote o callback+		-- use inplace when retrieving to support resuming+		[ Param "--inplace"+		, Param u+		, Param dest+		]  rsyncRemote :: RsyncOpts -> (Maybe MeterUpdate) -> [CommandParam] -> Annex Bool rsyncRemote o callback params = do
Remote/S3.hs view
@@ -152,9 +152,9 @@ 	xheaders = filter isxheader $ M.assocs $ config r 	isxheader (h, _) = "x-amz-" `isPrefixOf` h -retrieve :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool-retrieve r k _f d = s3Action r False $ \(conn, bucket) ->-	metered Nothing k $ \meterupdate -> do+retrieve :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool+retrieve r k _f d p = s3Action r False $ \(conn, bucket) ->+	metered (Just p) k $ \meterupdate -> do 		res <- liftIO $ getObject conn $ bucketKey r bucket k 		case res of 			Right o -> do@@ -166,9 +166,9 @@ retrieveCheap :: Remote -> Key -> FilePath -> Annex Bool retrieveCheap _ _ _ = return False -retrieveEncrypted :: Remote -> (Cipher, Key) -> Key -> FilePath -> Annex Bool-retrieveEncrypted r (cipher, enck) k d = s3Action r False $ \(conn, bucket) ->-	metered Nothing k $ \meterupdate -> do+retrieveEncrypted :: Remote -> (Cipher, Key) -> Key -> FilePath -> MeterUpdate -> Annex Bool+retrieveEncrypted r (cipher, enck) k d p = s3Action r False $ \(conn, bucket) ->+	metered (Just p) k $ \meterupdate -> do 		res <- liftIO $ getObject conn $ bucketKey r bucket enck 		case res of 			Right o -> liftIO $ decrypt cipher (\h -> meteredWrite meterupdate h $ obj_data o) $
Remote/Web.hs view
@@ -59,8 +59,8 @@ 		remotetype = remote 	} -downloadKey :: Key -> AssociatedFile -> FilePath -> Annex Bool-downloadKey key _file dest = get =<< getUrls key+downloadKey :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool+downloadKey key _file dest _p = get =<< getUrls key   where 	get [] = do 		warning "no known url"
Remote/WebDAV.hs view
@@ -118,8 +118,8 @@ retrieveCheap :: Remote -> Key -> FilePath -> Annex Bool retrieveCheap _ _ _ = return False -retrieve :: Remote -> Key -> AssociatedFile -> FilePath -> Annex Bool-retrieve r k _f d = metered Nothing k $ \meterupdate ->+retrieve :: Remote -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool+retrieve r k _f d p = metered (Just p) k $ \meterupdate -> 	davAction r False $ \(baseurl, user, pass) -> liftIO $ catchBoolIO $ 		withStoredFiles r k baseurl user pass onerr $ \urls -> do 			meteredWriteFileChunks meterupdate d urls $ \url -> do@@ -131,8 +131,8 @@   where 	onerr _ = return False -retrieveEncrypted :: Remote -> (Cipher, Key) -> Key -> FilePath -> Annex Bool-retrieveEncrypted r (cipher, enck) k d = metered Nothing k $ \meterupdate ->+retrieveEncrypted :: Remote -> (Cipher, Key) -> Key -> FilePath -> MeterUpdate -> Annex Bool+retrieveEncrypted r (cipher, enck) k d p = metered (Just p) k $ \meterupdate -> 	davAction r False $ \(baseurl, user, pass) -> liftIO $ catchBoolIO $ 		withStoredFiles r enck baseurl user pass onerr $ \urls -> do 			decrypt cipher (feeder user pass urls) $
Setup.hs view
@@ -13,7 +13,7 @@ import Control.Monad import System.Directory -import qualified Build.InstallDesktopFile as InstallDesktopFile+import qualified Build.DesktopFile as DesktopFile import qualified Build.Configure as Configure  main = defaultMainWithHooks simpleUserHooks@@ -58,6 +58,6 @@  installDesktopFile :: CopyDest -> Verbosity -> PackageDescription -> LocalBuildInfo -> IO () installDesktopFile copyDest verbosity pkg lbi =-	InstallDesktopFile.install $ dstBinDir </> "git-annex"+	DesktopFile.install $ dstBinDir </> "git-annex"   where 	dstBinDir = bindir $ absoluteInstallDirs pkg lbi copyDest
+ Setup.o view

binary file changed (absent → 10448 bytes)

Test.hs view
@@ -735,6 +735,7 @@ 			, "type=directory" 			, "encryption=" ++ Utility.Gpg.testKeyId 			, "directory=dir"+			, "highRandomQuality=false" 			] 		initremote @? "initremote failed" 		initremote @? "initremote failed when run twice in a row"
Types/GitConfig.hs view
@@ -36,6 +36,7 @@ 	, annexHttpHeadersCommand :: Maybe String 	, annexAutoCommit :: Bool 	, annexWebOptions :: [String]+	, annexWebDownloadCommand :: Maybe String 	, annexCrippledFileSystem :: Bool 	, annexLargeFiles :: Maybe String 	, coreSymlinks :: Bool@@ -59,6 +60,7 @@ 	, annexHttpHeadersCommand = getmaybe (annex "http-headers-command") 	, annexAutoCommit = getbool (annex "autocommit") True 	, annexWebOptions = getwords (annex "web-options")+	, annexWebDownloadCommand = getmaybe (annex "web-download-command") 	, annexCrippledFileSystem = getbool (annex "crippledfilesystem") False 	, annexLargeFiles = getmaybe (annex "largefiles") 	, coreSymlinks = getbool "core.symlinks" True@@ -92,6 +94,7 @@ 	 - including special remotes. -} 	, remoteAnnexSshOptions :: [String] 	, remoteAnnexRsyncOptions :: [String]+	, remoteAnnexRsyncTransport :: [String] 	, remoteAnnexGnupgOptions :: [String] 	, remoteAnnexRsyncUrl :: Maybe String 	, remoteAnnexBupRepo :: Maybe String@@ -114,6 +117,7 @@  	, remoteAnnexSshOptions = getoptions "ssh-options" 	, remoteAnnexRsyncOptions = getoptions "rsync-options"+	, remoteAnnexRsyncTransport = getoptions "rsync-transport" 	, remoteAnnexGnupgOptions = getoptions "gnupg-options" 	, remoteAnnexRsyncUrl = notempty $ getmaybe "rsyncurl" 	, remoteAnnexBupRepo = getmaybe "buprepo"
Types/Remote.hs view
@@ -50,8 +50,10 @@ 	cost :: Cost, 	-- Transfers a key to the remote. 	storeKey :: Key -> AssociatedFile -> MeterUpdate -> a Bool,-	-- retrieves a key's contents to a file-	retrieveKeyFile :: Key -> AssociatedFile -> FilePath -> a Bool,+	-- Retrieves a key's contents to a file.+	-- (The MeterUpdate does not need to be used if it retrieves+	-- directly to the file, and not to an intermediate file.)+	retrieveKeyFile :: Key -> AssociatedFile -> FilePath -> MeterUpdate -> a Bool, 	-- retrieves a key's contents to a tmp file, if it can be done cheaply 	retrieveKeyFileCheap :: Key -> FilePath -> a Bool, 	-- removes a key's contents
Types/StandardGroups.hs view
@@ -55,21 +55,22 @@  {- See doc/preferred_content.mdwn for explanations of these expressions. -} preferredContent :: StandardGroup -> String-preferredContent ClientGroup = lastResort-	"exclude=*/archive/* and exclude=archive/*"-preferredContent TransferGroup = lastResort-	"not (inallgroup=client and copies=client:2) and " ++ preferredContent ClientGroup+preferredContent ClientGroup = lastResort $+	"(exclude=*/archive/* and exclude=archive/*) or (" ++ notArchived ++ ")"+preferredContent TransferGroup = lastResort $+	"not (inallgroup=client and copies=client:2) and (" ++ preferredContent ClientGroup ++ ")" preferredContent BackupGroup = "include=*"-preferredContent IncrementalBackupGroup = lastResort+preferredContent IncrementalBackupGroup = lastResort $ 	"include=* and (not copies=incrementalbackup:1)" preferredContent SmallArchiveGroup = lastResort $-	"(include=*/archive/* or include=archive/*) and " ++ preferredContent FullArchiveGroup-preferredContent FullArchiveGroup = lastResort-	"not (copies=archive:1 or copies=smallarchive:1)"+	"(include=*/archive/* or include=archive/*) and (" ++ preferredContent FullArchiveGroup ++ ")"+preferredContent FullArchiveGroup = lastResort notArchived preferredContent SourceGroup = "not (copies=1)"-preferredContent ManualGroup = lastResort-	"present and exclude=*/archive/* and exclude=archive/*"+preferredContent ManualGroup = "present and (" ++ preferredContent ClientGroup ++ ")" preferredContent UnwantedGroup = "exclude=*"++notArchived :: String+notArchived = "not (copies=archive:1 or copies=smallarchive:1)"   	 {- Most repositories want any content that is only on untrusted  - or dead repositories. -}
Usage.hs view
@@ -95,6 +95,8 @@ paramGroup = "GROUP" paramSize :: String paramSize = "SIZE"+paramAddress :: String+paramAddress = "ADDRESS" paramKeyValue :: String paramKeyValue = "K=V" paramNothing :: String
+ Utility/Applicative.o view

binary file changed (absent → 1308 bytes)

+ Utility/Directory.o view

binary file changed (absent → 15324 bytes)

+ Utility/Exception.o view

binary file changed (absent → 7228 bytes)

+ Utility/FileSystemEncoding.o view

binary file changed (absent → 5668 bytes)

+ Utility/FreeDesktop.o view

binary file changed (absent → 21064 bytes)

Utility/Gpg.hs view
@@ -85,7 +85,8 @@ 		reader from  {- Finds gpg public keys matching some string. (Could be an email address,- - a key id, or a name. -}+ - a key id, or a name; See the section 'HOW TO SPECIFY A USER ID' of+ - GnuPG's manpage.) -} findPubKeys :: String -> IO KeyIds findPubKeys for = KeyIds . parse <$> readStrict params   where@@ -97,8 +98,8 @@ {- Creates a block of high-quality random data suitable to use as a cipher.  - It is armored, to avoid newlines, since gpg only reads ciphers up to the  - first newline. -}-genRandom :: Int -> IO String-genRandom size = checksize <$> readStrict+genRandom :: Bool -> Int -> IO String+genRandom highQuality size = checksize <$> readStrict 	[ Params params 	, Param $ show randomquality 	, Param $ show size@@ -106,8 +107,13 @@   where 	params = "--gen-random --armor" -	-- 1 is /dev/urandom; 2 is /dev/random-	randomquality = 1 :: Int+	-- See http://www.gnupg.org/documentation/manuals/gcrypt/Quality-of-random-numbers.html+	-- for the meaning of random quality levels.+	-- The highest available is 2, which is the default for OpenPGP+	-- key generation; Note that it uses the blocking PRNG /dev/random+	-- on the Linux kernel, hence the running time may take a while.+	randomquality :: Int+	randomquality = if highQuality then 2 else 1   	{- The size is the number of bytes of entropy desired; the data is 	 - base64 encoded, so needs 8 bits to represent every 6 bytes of
Utility/Misc.hs view
@@ -11,6 +11,7 @@ import Control.Monad import Foreign import Data.Char+import Data.List import Control.Applicative import System.Posix.Process (getAnyProcessStatus) @@ -69,6 +70,23 @@ 	go c r (i:is) 		| p i = go [] ([i]:c:r) is 		| otherwise = go (i:c) r is++{- Replaces multiple values in a string.+ -+ - Takes care to skip over just-replaced values, so that they are not+ - mangled. For example, massReplace [("foo", "new foo")] does not+ - replace the "new foo" with "new new foo".+ -}+massReplace :: [(String, String)] -> String -> String+massReplace vs = go [] vs+  where++	go acc _ [] = concat $ reverse acc+	go acc [] (c:cs) = go ([c]:acc) vs cs+	go acc ((val, replacement):rest) s+		| val `isPrefixOf` s =+			go (replacement:acc) vs (drop (length val) s)+		| otherwise = go acc rest s  {- Given two orderings, returns the second if the first is EQ and returns  - the first otherwise.
+ Utility/Misc.o view

binary file changed (absent → 19232 bytes)

+ Utility/Monad.o view

binary file changed (absent → 7376 bytes)

+ Utility/OSX.o view

binary file changed (absent → 8808 bytes)

+ Utility/PartialPrelude.o view

binary file changed (absent → 5456 bytes)

Utility/Path.hs view
@@ -1,10 +1,11 @@-{-# LANGUAGE PackageImports #-} {- path manipulation  -  - Copyright 2010-2011 Joey Hess <joey@kitenet.net>  -  - Licensed under the GNU GPL version 3 or higher.  -}++{-# LANGUAGE PackageImports #-}  module Utility.Path where
+ Utility/Path.o view

binary file changed (absent → 23740 bytes)

+ Utility/Process.o view

binary file changed (absent → 42568 bytes)

+ Utility/SafeCommand.o view

binary file changed (absent → 28136 bytes)

Utility/State.hs view
@@ -5,8 +5,6 @@  - Licensed under the GNU GPL version 3 or higher.  -} -{-# LANGUAGE PackageImports #-}- module Utility.State where  import "mtl" Control.Monad.State.Strict
+ Utility/TempFile.o view

binary file changed (absent → 11404 bytes)

Utility/Url.hs view
@@ -1,6 +1,6 @@ {- Url downloading.  -- - Copyright 2011 Joey Hess <joey@kitenet.net>+ - Copyright 2011,2013 Joey Hess <joey@kitenet.net>  -  - Licensed under the GNU GPL version 3 or higher.  -}@@ -17,7 +17,12 @@  import Common import Network.URI+import qualified Network.Browser as Browser+import Network.HTTP+import Data.Either +import qualified Build.SysConfig+ type URLString = String  type Headers = [String]@@ -32,7 +37,13 @@ 	handle (True, s) = expected_size == s  {- Checks that an url exists and could be successfully downloaded,- - also returning its size if available. -}+ - also returning its size if available. + -+ - For a file: url, check it directly.+ -+ - Uses curl otherwise, when available, since curl handles https better+ - than does Haskell's Network.Browser.+ -} exists :: URLString -> Headers -> IO (Bool, Maybe Integer) exists url headers = case parseURIRelaxed url of 	Just u@@ -41,11 +52,17 @@ 			case s of 				Just stat -> return (True, Just $ fromIntegral $ fileSize stat) 				Nothing -> dne-		| otherwise -> do-			output <- readProcess "curl" curlparams-			case lastMaybe (lines output) of-				Just ('2':_:_) -> return (True, extractsize output)-				_ -> dne+		| otherwise -> if Build.SysConfig.curl+			then do+				output <- readProcess "curl" curlparams+				case lastMaybe (lines output) of+					Just ('2':_:_) -> return (True, extractsize output)+					_ -> dne+			else do+				r <- request u headers HEAD+				case rspCode r of+					(2,_,_) -> return (True, size r)+					_ -> return (False, Nothing) 	Nothing -> dne   where 	dne = return (False, Nothing)@@ -64,6 +81,8 @@ 			_ -> Nothing 		_ -> Nothing +	size = liftM Prelude.read . lookupHeader HdrContentLength . rspHeaders+ {- Used to download large files, such as the contents of keys.  -  - Uses wget or curl program for its progress bar. (Wget has a better one,@@ -94,10 +113,63 @@ 	go cmd opts = boolSystem cmd $ 		options++opts++[File file, File url] -{- Downloads a small file. -}+{- Downloads a small file.+ -+ - Uses curl if available since it handles HTTPS better than+ - the Haskell libraries do. -} get :: URLString -> Headers -> IO String-get url headers = readProcess "curl" $-	["-s", "-L", url] ++ concatMap (\h -> ["-H", h]) headers+get url headers = if Build.SysConfig.curl+	then readProcess "curl" $+		["-s", "-L", url] ++ concatMap (\h -> ["-H", h]) headers+	else case parseURI url of+		Nothing -> error "url parse error"+		Just u -> do+			r <- request u headers GET+			case rspCode r of+				(2,_,_) -> return $ rspBody r+				_ -> error $ rspReason r++{- Uses Network.Browser to make a http request of an url.+ - For example, HEAD can be used to check if the url exists,+ - or GET used to get the url content (best for small urls).+ -+ - This does its own redirect following because Browser's is buggy for HEAD+ - requests.+ -}+request :: URI -> Headers -> RequestMethod -> IO (Response String)+request url headers requesttype = go 5 url+  where+	go :: Int -> URI -> IO (Response String)+	go 0 _ = error "Too many redirects "+	go n u = do+		rsp <- Browser.browse $ do+			Browser.setErrHandler ignore+			Browser.setOutHandler ignore+			Browser.setAllowRedirects False+			let req = mkRequest requesttype u :: Request_String+			snd <$> Browser.request (addheaders req)+		case rspCode rsp of+			(3,0,x) | x /= 5 -> redir (n - 1) u rsp+			_ -> return rsp+	addheaders req = setHeaders req (rqHeaders req ++ userheaders)+	userheaders = rights $ map parseHeader headers+	ignore = const noop+	redir n u rsp = case retrieveHeaders HdrLocation rsp of+		[] -> return rsp+		(Header _ newu:_) ->+			case parseURIReference newu of+				Nothing -> return rsp+				Just newURI -> go n $+#if defined VERSION_network+#if ! MIN_VERSION_network(2,4,0)+#define WITH_OLD_URI+#endif+#endif+#ifdef WITH_OLD_URI+					fromMaybe newURI (newURI `relativeTo` u)+#else+					newURI `relativeTo` u+#endif  {- Allows for spaces and other stuff in urls, properly escaping them. -} parseURIRelaxed :: URLString -> Maybe URI
+ Utility/UserInfo.o view

binary file changed (absent → 6328 bytes)

Utility/WebApp.hs view
@@ -20,7 +20,6 @@ import Control.Monad.IO.Class import Network.HTTP.Types import System.Log.Logger-import Data.ByteString.Lazy.UTF8 import qualified Data.CaseInsensitive as CI import Network.Socket import Control.Exception@@ -28,6 +27,7 @@ import Data.Digest.Pure.SHA import qualified Web.ClientSession as CS import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.UTF8 as L8 import qualified Data.ByteString as B import qualified Data.Text as T import qualified Data.Text.Encoding as TE@@ -37,7 +37,7 @@ import Control.Arrow ((***)) import Control.Concurrent -localhost :: String+localhost :: HostName localhost = "localhost"  {- Command to use to run a web browser. -}@@ -48,14 +48,15 @@ browserCommand = "xdg-open" #endif -{- Binds to a socket on localhost, and runs a webapp on it.+{- Binds to a socket on localhost, or possibly a different specified+ - hostname or address, and runs a webapp on it.  -  - An IO action can also be run, to do something with the address,  - such as start a web browser to view the webapp.  -}-runWebApp :: Wai.Application -> (SockAddr -> IO ()) -> IO ()-runWebApp app observer = do-	sock <- localSocket+runWebApp :: Maybe HostName -> Wai.Application -> (SockAddr -> IO ()) -> IO ()+runWebApp h app observer = do+	sock <- getSocket h 	void $ forkIO $ runSettingsSocket webAppSettings sock app 	observer =<< getSocketName sock @@ -65,21 +66,22 @@ 	{ settingsTimeout = 30 * 60 	} -{- Binds to a local socket, selecting any free port.+{- Binds to a local socket, or if specified, to a socket on the specified+ - hostname or address. Selets any free port, unless the hostname ends with+ - ":port"  -  - Prefers to bind to the ipv4 address rather than the ipv6 address  - of localhost, if it's available.- -- - As a (very weak) form of security, only connections from - - localhost are accepted. -}-localSocket :: IO Socket-localSocket = do-	addrs <- getAddrInfo (Just hints) (Just localhost) Nothing+ -}+getSocket :: Maybe HostName -> IO Socket+getSocket h = do+	addrs <- getAddrInfo (Just hints) (Just hostname) port 	case (partition (\a -> addrFamily a == AF_INET) addrs) of 		(v4addr:_, _) -> go v4addr 		(_, v6addr:_) -> go v6addr 		_ -> error "unable to bind to a local socket"   where+	(hostname, port) = maybe (localhost, Nothing) splitHostPort h 	hints = defaultHints 		{ addrFlags = [AI_ADDRCONFIG] 		, addrSocketType = Stream@@ -99,6 +101,18 @@ 		listen sock maxListenQueue 		return sock +{- Splits address:port. For IPv6, use [address]:port. The port is optional. -}+splitHostPort :: String -> (HostName, Maybe ServiceName)+splitHostPort s+	| "[" `isPrefixOf` s = let (h, p) = break (== ']') (drop 1 s)+		in if "]:" `isPrefixOf` p+			then (h, Just $ drop 2 p)+			else (h, Nothing)+	| otherwise = let (h, p) = separate (== ':') s+		in if null p+			then (h, Nothing)+			else (h, Just p)+ {- Checks if debugging is actually enabled. -} debugEnabled :: IO Bool debugEnabled = do@@ -126,7 +140,7 @@ 		, frombs $ lookupRequestField "user-agent" req 		]   where-	frombs v = toString $ L.fromChunks [v]+	frombs v = L8.toString $ L.fromChunks [v]  lookupRequestField :: CI.CI B.ByteString -> Wai.Request -> B.ByteString lookupRequestField k req = fromMaybe "" . lookup k $ Wai.requestHeaders req
Utility/Yesod.hs view
@@ -9,6 +9,7 @@  module Utility.Yesod where +#ifndef __ANDROID__ import Yesod.Default.Util import Language.Haskell.TH.Syntax #if MIN_VERSION_yesod_default(1,1,0)@@ -29,3 +30,4 @@  hamletTemplate :: FilePath -> FilePath hamletTemplate f = globFile "hamlet" f+#endif
debian/changelog view
@@ -1,3 +1,50 @@+git-annex (4.20130417) unstable; urgency=low++  * initremote: Generates encryption keys with high quality entropy.+    This can be disabled using --fast to get the old behavior.+    The assistant still uses low-quality entropy when creating encrypted+    remotes, to avoid delays. (Thanks, guilhem for the patch.)+  * Bugfix: Direct mode no longer repeatedly checksums duplicated files.+  * assistant: Work around horrible, terrible, very bad behavior of+    gnome-keyring, by not storing special-purpose ssh keys in ~/.ssh/*.pub.+    Apparently gnome-keyring apparently will load and indiscriminately use+    such keys in some cases, even if they are not using any of the standard+    ssh key names. Instead store the keys in ~/.ssh/annex/,+    which gnome-keyring will not check.+  * addurl: Bugfix: Did not properly add file in direct mode.+  * assistant: Bug fix to avoid annexing the files that git uses+    to stand in for symlinks on FAT and other filesystem not supporting+    symlinks.+  * Adjust preferred content expressions so that content in archive+    directories is preferred until it has reached an archive or smallarchive+    repository.+  * webapp: New --listen= option allows running the webapp on one computer+    and connecting to it from another. (Note: Does not yet use HTTPS.)+  * Added annex.web-download-command setting.+  * Added per-remote annex-rsync-transport option. (guilhem again)+  * Ssh connection caching is now also used by rsync special remotes.+    (guilhem yet again)+  * The version number is now derived from git, unless built with+    VERSION_FROM_CHANGELOG.+  * assistant: Stop any transfers the assistant initiated on shutdown.+  * assistant: Added sequence numbers to XMPP git push packets. (Not yet used.)+  * addurl: Register transfer so the webapp can see it.+  * addurl: Automatically retry downloads that fail, as long as some+    additional content was downloaded.+  * webapp: Much improved progress bar display for downloads from encrypted+    remotes.+  * Avoid using runghc, as that needs ghci.+  * webapp: When a repository's group is changed, rescan for transfers.+  * webapp: Added animations.+  * webapp: Include the repository directory in the mangled hostname and+    ssh key name, so that a locked down ssh key for one repository is not+    re-used when setting up additional repositories on the same server.+  * Fall back to internal url downloader when built without curl.+  * fsck: Check content of direct mode files (only when the inode cache+    thinks they are unmodified).++ -- Joey Hess <joeyh@debian.org>  Wed, 17 Apr 2013 09:07:38 -0400+ git-annex (4.20130405) unstable; urgency=low    * Group subcommands into sections in usage. Closes: #703797
debian/control view
@@ -45,11 +45,13 @@ 	libghc-gnutls-dev (>= 0.1.4), 	libghc-xml-types-dev, 	libghc-async-dev,+	libghc-http-dev, 	ikiwiki, 	perlmagick, 	git,-	uuid, 	rsync,+	wget,+	curl, 	openssh-client, Maintainer: Joey Hess <joeyh@debian.org> Standards-Version: 3.9.3@@ -61,7 +63,6 @@ Section: utils Depends: ${misc:Depends}, ${shlibs:Depends}, 	git (>= 1:1.7.7.6),-	uuid, 	rsync, 	wget, 	curl,
debian/rules view
@@ -1,7 +1,10 @@ #!/usr/bin/make -f  # Avoid using cabal, as it writes to $HOME-export CABAL=runghc Setup.hs+export CABAL=./Setup++# Do use the changelog's version number, rather than making one up.+export VERSION_FROM_CHANGELOG=1  %: 	dh $@
+ doc/assistant/example.png view

binary file changed (absent → 110994 bytes)

doc/assistant/release_notes.mdwn view
@@ -1,3 +1,7 @@+## version 4.20130323, 4.20130405++These versions continue fixing bugs and adding features.+ ## version 4.20130314  This version makes a great many improvements and bugfixes, and is
+ doc/bugs/Add_another_repository_on_USB_drive_causes_sync_loop.mdwn view
@@ -0,0 +1,22 @@+What steps will reproduce the problem?++Mount USB drive formatted as FAT+Make directory for repository in it.+Set up another repository and choose to sync it with the existing one.++What is the expected output? What do you see instead?+The files should transfer from the main repository to the directory on the USB drive.+This happens, but afterwards a new sync happens from the USB drive repository back to the other existing repositories, because the file date of all the files on the USB drive has been set to today.+Further, git seemed to keep the USB key locked so umount was impossible until after killing it.++What version of git-annex are you using? On what operating system?+4.20130405+Linux++Please provide any additional information below.+++> Reproduced the core bug, which is that the assistant saw symlink standin+> files as new files, and annexed them. Now it doesn't, and I have+> it running on FAT with no trouble; can even rename symlink standin files+> and it commits symlink changes. Calling this [[done]]. --[[Joey]]
+ doc/bugs/Adding_second_remote_repository_over_ssh_fails.mdwn view
@@ -0,0 +1,37 @@+What steps will reproduce the problem?++Create a local and "remote server" repository++Create another local repositorty and keep it seperate from the first one. Fails while creating second repository on the remote.++What is the expected output? What do you see instead?++Expected to get two seperate repositories on the client and server. Only first one works.++Got an error:++    Failed to make repository++    Something went wrong setting up the repository on the remote server.++    Transcript: fatal: unrecognized command 'sh -c 'mkdir -p '"'"'second'"'"'&&cd '"'"'second'"'"'&&git init --bare --shared&&git annex init&&mkdir -p ~/.ssh&&if [ ! -e ~/.ssh/git-annex-shell ]; then (echo '"'"'#!/bin/sh'"'"';echo '"'"'set -e'"'"';echo '"'"'if [ "x$SSH_ORIGINAL_COMMAND" != "x" ]; then'"'"';echo '"'"'exec git-annex-shell -c "$SSH_ORIGINAL_COMMAND"'"'"';echo '"'"'else'"'"';echo '"'"'exec git-annex-shell -c "$@"'"'"';echo '"'"'fi'"'"') > ~/.ssh/git-annex-shell; fi&&chmod 700 ~/.ssh/git-annex-shell&&touch ~/.ssh/authorized_keys&&chmod 600 ~/.ssh/authorized_keys&&echo '"'"'command="GIT_ANNEX_SHELL_DIRECTORY='"'"'"'"'"'"'"'"'second'"'"'"'"'"'"'"'"' ~/.ssh/git-annex-shell",no-agent-forwarding,no-port-forwarding,no-X11-forwarding ssh-rsa AAAAB3NzaC1yc2EAAAADAQABAAABAQCvoTn+XBdlw/mQlu+NScAeuddUJqJaVXH6KUsO09OddnUvzv4W185ezbAjXfWDgN7ou0Q0xQzwiCzdoSl7T3USJQ1ywTG5Xt2sBV3RIqxyReNA7Nz0yhwWhZBJcFzof34ezNIsi9NVgEJcK2JEs2XqhO5wK5nxEDeays7ti2bqY6V21iOWSy9hlzjD4VTWTEFxQkDp4BCzDpPN934ztOtInwI8ayiTRJZlNQ+ej/AaA+/zOBWNvIFc/96iuMLKY6lLFThw1jNj5r5N7yPaysLdnwTJ3irtCzDygCpD4mau4frrOPvG90ZdcdrQSfIjRtM9nPZ5jIpohfvz0dIfgNFz marvin@marvin-U-100 '"'"' >>~/.ssh/authorized_keys'' git-annex-shell: git-shell failed+++What version of git-annex are you using? On what operating system?++4.20130413-g5747bf4 ubuntu 12.10 local++3.20120629 debian wheezy remote (also tried 4.20130413-g5747bf4)++Please provide any additional information below.++> This bug would appear to be the same as a bug I fixed today.+> +> Except this last bit:++**Also noticed if a user has no full name set in unix account, creating+remote repository always fails**++> So, I'm going to repurpose this bug to track that problem. --[[Joey]]++[[!meta title="assistant can fail to make git repository if remote server is lacking GECOS"]]
+ doc/bugs/Addurl_downloads_but_does_not_checkout_files.mdwn view
@@ -0,0 +1,74 @@+What steps will reproduce the problem?++Example below illustrates downloading a podcast with git annex addurl:++list directory before...++~/Podcasts/TuxRadar Linux Podcast (Ogg)$ ls+folder.jpg           tuxradar_s04e24.ogg+tuxradar_s04e09.ogg  tuxradar_s05e01.ogg+tuxradar_s04e11.ogg  tuxradar_s05e02.ogg+tuxradar_s04e13.ogg  tuxradar_s05e03.ogg+tuxradar_s04e15.ogg  tuxradar_s05e04.ogg+tuxradar_s04e16.ogg  www.tuxradar.com_files_podcast_tuxradar_s04e10.ogg+tuxradar_s04e19.ogg  www.tuxradar.com_files_podcast_tuxradar_s04e12.ogg+tuxradar_s04e20.ogg  www.tuxradar.com_files_podcast_tuxradar_s04e14.ogg+tuxradar_s04e21.ogg  www.tuxradar.com_files_podcast_tuxradar_s04e17.ogg+tuxradar_s04e22.ogg  www.tuxradar.com_files_podcast_tuxradar_s04e18.ogg+tuxradar_s04e23.ogg++download file...++~/Podcasts/TuxRadar Linux Podcast (Ogg)$ git annex addurl http://www.tuxradar.com/files/podcast/tuxradar_s05e05.ogg+addurl www.tuxradar.com_files_podcast_tuxradar_s05e05.ogg (downloading http://www.tuxradar.com/files/podcast/tuxradar_s05e05.ogg ...) --2013-04-10 21:18:12--  http://www.tuxradar.com/files/podcast/tuxradar_s05e05.ogg+Resolving www.tuxradar.com (www.tuxradar.com)... 80.244.178.150+Connecting to www.tuxradar.com (www.tuxradar.com)|80.244.178.150|:80... connected.+HTTP request sent, awaiting response... 200 OK+Length: 33249291 (32M) [application/ogg]+Saving to: `/home/rob/Podcasts/.git/annex/tmp/URL--http&c%%www.tuxradar.com%files%podcast%tuxradar_s05e05.ogg'++100%[===============================>] 33,249,291   404K/s   in 81s     ++2013-04-10 21:19:35 (399 KB/s) - `/home/rob/Podcasts/.git/annex/tmp/URL--http&c%%www.tuxradar.com%files%podcast%tuxradar_s05e05.ogg' saved [33249291/33249291]++(checksum...) ok+(Recording state in git...)++file appears to have been downloaded, but isn't there...++~/Podcasts/TuxRadar Linux Podcast (Ogg)$ ls+folder.jpg           tuxradar_s04e24.ogg+tuxradar_s04e09.ogg  tuxradar_s05e01.ogg+tuxradar_s04e11.ogg  tuxradar_s05e02.ogg+tuxradar_s04e13.ogg  tuxradar_s05e03.ogg+tuxradar_s04e15.ogg  tuxradar_s05e04.ogg+tuxradar_s04e16.ogg  www.tuxradar.com_files_podcast_tuxradar_s04e10.ogg+tuxradar_s04e19.ogg  www.tuxradar.com_files_podcast_tuxradar_s04e12.ogg+tuxradar_s04e20.ogg  www.tuxradar.com_files_podcast_tuxradar_s04e14.ogg+tuxradar_s04e21.ogg  www.tuxradar.com_files_podcast_tuxradar_s04e17.ogg+tuxradar_s04e22.ogg  www.tuxradar.com_files_podcast_tuxradar_s04e18.ogg+tuxradar_s04e23.ogg++What is the expected output? What do you see instead?++File should exist in current directory. As you can see from above output, this has worked in the past (with older versions).++What version of git-annex are you using? On what operating system?++git-annex version: 4.20130405+local repository version: 3+default repository version: 3+supported repository versions: 3 4+upgrade supported from repository versions: 0 1 2+build flags: Assistant Webapp Pairing Testsuite S3 WebDAV Inotify DBus XMPP++OS: Debian Testing/Unstable++Please provide any additional information below.++The repository in question was created by the assistant and I tried the above with the assistant both running and not running, with no difference. I have also tried downloading other files.++EDIT: formatting++> Bug only affected direct mode. I think it used to work but I broke+> it when fixing another bug in direct mode. [[fixed|done]] --[[Joey]]
doc/bugs/Direct_mode_keeps_re-checksuming_duplicated_files.mdwn view
@@ -20,3 +20,6 @@ ##What version of git-annex are you using? On what operating system?  git-annex version: 4.20130227 on Archlinux++> [[done]]; fixed inode caching code to support multiple files for the+> same content. --[[Joey]]
+ doc/bugs/Files_disappear_from_locally_paired_annexes_when_edited.mdwn view
@@ -0,0 +1,34 @@+**What steps will reproduce the problem?**++Create two annexes from the command line on two separate machines:++    mkdir ~/Files.annex+    cd ~/Files.annex+    git init+    git annex init+    git annex untrust .+    git annex direct++Add remote to each one pointing to the other:++    git remote add [remote] [remote hostname]:Files.annex++Start assistant on both repos:++    git annex assistant++Fill one repository with a few text files, and wait for them to propagate.++Edit one of the text files using vim, and save.++**What is the expected output? What do you see instead?**++Edited file should remain in the repo, but a significant portion of the time, the file disappeared from the repo in which it was edited (the file is present and properly synced on the other repo).++**What version of git-annex are you using? On what operating system?**++git-annex 4.20130323, Mac OS X on the repo where the file was edited, Arch Linux for the other paired repo.++**Please provide any additional information below.**++I have observed this problem setting up the repos through the webapp as well, so I don't think it is related to setting up the repos manually. I think the way vim is writing the files seems to be tickling a race condition (both command-line vim and MacVim produce the behavior). I started trying to work around it by switching to emacs to edit those files, and the files haven't disappeared from the edited repo (so far at least).
+ doc/bugs/Incorrect_version_on_64_Standalone_Build.mdwn view
@@ -0,0 +1,11 @@+    $ wget http://downloads.kitenet.net/git-annex/linux/current/git-annex-standalone-amd64.tar.gz+    $ tar xvzf git-annex-standalone-amd64.tar.gz+    $ cd git-annex.linux+    $ ./git-annex version+    git-annex version: 4.20130324++Shouldn't that be `4.20130405`?++The md5sum of the build I downloaded is `aabbb3aa2397be206cae86f33db9eef4`.++> [[done]]; new version will look like eg `4.20130410-gc149c67` --[[Joey]]
+ doc/bugs/OSX_app_issues/comment_10_6d23232fbb15d0ee3ab532a4884f81ed._comment view
@@ -0,0 +1,10 @@+[[!comment format=mdwn+ username="http://joeyh.name/"+ nickname="joey"+ subject="comment 10"+ date="2013-04-16T17:14:13Z"+ content="""+@Jeremy, it's been a long time since anyone reported having the \"LSOpenURLsWithRole()\". It seemed to go away when the dmg was fixed to include all the necessary libraries. So my guess is you installed it wrong, somehow, and perhaps it's not finding those libraries that are part of the dmg.++You should be able to start the assistant by running it directly from the dmg.+"""]]
+ doc/bugs/OSX_app_issues/comment_11_5db2baa771fd01a284eac8a16c1c8c67._comment view
@@ -0,0 +1,8 @@+[[!comment format=mdwn+ username="https://www.google.com/accounts/o8/id?id=AItOawlkAghrKEvslMcV2INKUhtPPMsfnzQyyd8"+ nickname="Jeremy"+ subject="comment 11"+ date="2013-04-17T02:02:00Z"+ content="""+@joey, figured it out. There was a program added to the startup list, presumably from when I ran things from the dmg a while ago. Once I delete that, it started fine. Of course, I forgot to write down the name of the program... I remember it had an LW in the name.+"""]]
+ doc/bugs/OSX_app_issues/comment_9_e1bbe83a1b9a7385ed6d443d0cc22bc7._comment view
@@ -0,0 +1,18 @@+[[!comment format=mdwn+ username="https://www.google.com/accounts/o8/id?id=AItOawlkAghrKEvslMcV2INKUhtPPMsfnzQyyd8"+ nickname="Jeremy"+ subject="Unable to start assistant"+ date="2013-04-16T01:07:05Z"+ content="""+I got the git-annex assistant to work once a long time ago when I ran it the first time directly from the dmg. Ever since then (i.e., after putting it in my applications folder) I have never gotten it to run. Wondering if anyone else has experienced this?++I am running OSX 10.7.5 and just pulled the latest app (05-Apr-2013 10:17).++For reference, when I try to kick off the the assistant from the command line I get the error:++    $ open /Applications/git-annex.app+    LSOpenURLsWithRole() failed with error -10810 for the file /Applications/git-annex.app.++I am wondering if there is some sort of file or modification that was made when I accidently kicked it off initially from the dmg, if so any thoughts on what to clear / change?++"""]]
doc/bugs/Rsync_encrypted_remote_asks_for_ssh_key_password_for_each_file.mdwn view
@@ -25,3 +25,6 @@   [[!meta title="rsync special remote does not use ssh connection caching"]]++> [[done]]; ssh connection caching is now done for these remotes.+> --[[Joey]]
+ doc/bugs/The_assistant_hangs_forever.mdwn view
@@ -0,0 +1,46 @@+What steps will reproduce the problem?++1. Open the assistant with git-annex webapp+2. Click add another repository+3. Choose "add another repository"+4. Use "/home/pierre/testme" (try and get the problem with a new directory or an existing directory)+5. Press "Make Repository"+5. Choose "Keep the repository separate" ++What is the expected output? What do you see instead?++Go to the created repository but the interface hangs forever+I have 4 git-annex processes that use no CPUs.+I can still use the UI by clicking around with success or even shutdown the daemon.+If I shutdown the daemon, all git-annex process gets killed.++What version of git-annex are you using? On what operating system?++It is said to be git-annex version: 4.20130324 but it is actually 4.20130405 (known bug)++Please provide any additional information below.+++OS: Arch linux, bin package (not installed from source)+All tests are OK+Nothing happens on the log pages++This is so weird that I would like to see the log file but I cannot find it. I have looked at /var/log without success.+I have tried other available version on Arch linux (AUR git-annex-bin, AUR git-annex-standalone, haskell-web git-annex) and they all exhibit the same problem.+At that stage, what I would like to be able is to try to figure out what is going on using the log file.+Thanks++> This could happen when using the amd64 standalone build, because I +> forgot to install curl into its chroot, so it was not included in the+> bundle. If the host system also lacked curl, or something prevented+> curl from working, it would fail like this.+> +> I've included curl into the amd64 standalone build. I've also made the+> assistant fall back to using a built-in http client if it is built+> without curl.+> +> None of which helps at all with the Arch git-annex-bin hack, since+> that binary will be built with a working curl (when my amd64 standalone+> builder builds it), and then installed onto a system, that,+> apparently, has a broken curl. Which is one of many reasons I cannot+> support that hack. [[done]] --[[Joey]]
+ doc/bugs/Use_a_git_repository_on_the_server_don__39__t_work.mdwn view
@@ -0,0 +1,14 @@+What steps will reproduce the problem?+1. Create a Repository+2. Add a Remote Server++What is the expected output? What do you see instead?+The option "Use a git repository on the server" is marked as not available++What version of git-annex are you using? On what operating system?+Version: 4.20130405 but on Webapp ist shows: Version: 4.20130324+Linux 64bit++Please provide any additional information below.+git and git-annex are available on the Remote Server+
+ doc/bugs/Weird_behaviour_of_direct_and_indirect_annexes.mdwn view
@@ -0,0 +1,52 @@+## What steps will reproduce the problem?++    ~$ git annex webapp+++* Add Another Local Repository (~/Direct) "Direct", keep separate (from existing repo) no repo type+* Add Repository, ~/Indirect "Indirect", combine (with Direct) , repo type client+* Syncing enabled on both++Then++    ~/Indirect$ git annex indirect+    commit  ok+    indirect  ok+    ok+    ~/Indirect$ touch ../Direct/Test.File+    ++## What is the expected output? What do you see instead?++That ~/Indirect/Test.File be a symlink into .git/annex/objects/.......++Instead, it is not a symlink. However, doing++    ~/Indirect$ git annex direct+    ~/Indirect$ git annex indirect++results in what I would expect (until the content of Direct/Test.File is changed, when it ceases to be a symlink in ~/Indirect once more)++++## What version of git-annex are you using? On what operating system?+git-annex version: 4.20130405++Ubuntu 12.10+++## Please provide any additional information below.++Reading [[direct_mode]], I thought that I could have two repos on my computer, one direct, and one indirect, and if running the assistant, that I could gain the security of retaining old versions, as well as the convenience of direct mode. (I think I understand that correctly; if a direct-mode file only exists in one repository, and is edited, the old version is lost, but if it is in multiple repos, then the old versions will be retained).++It seems to me that if I do++    ~/Direct$ echo Content > Test.File+    ~/Direct$ echo More Content > Test.File+    ~/Direct$ echo Even More Content > Test.File++that all three copies are stored in ~/Indirect, so the functionality I'm after seems to work. However, ~/Indirect/Test.File ends up not being a symlink, which I think is odd/unexpected.+++**Edit:  Doing a git annex sync in ~/Indirect results in the continuing behaviour to be correct, so there's some issue telling Direct that Indirect is no longer in direct-mode?**+This appears to fix it, but I guess shouldn't be necessary.
+ doc/bugs/assistant_does_not_warn_on_files_it_failed_to_add.mdwn view
@@ -0,0 +1,24 @@+What steps will reproduce the problem?++Unable to reproduce as it seems to happen randomly, to very few files (4/250).++What is the expected output? What do you see instead?++I expect to see the assistant warn if it attempts to add a file which fails to add to the annex.+Instead, I see no output from the assistant, but lines like this in the log.++daemon.log.2:add Indie Game Stand/Deadly 30/Deadly30_MAC.zip (checksum...) failed+daemon.log.2:add Indie Game Stand/Wyv and Keep/xnafx40_redist.msi (checksum...) failed+daemon.log.2:add Indie Game Stand/Blueberry Garden/Blueberry_Garden_1.1.zip (checksum...) failed+daemon.log.2:add Indie Game Stand/Flatspace Bundle/fsmusicpack3setup.exe (checksum...) failed++There is no reason given for the failure in the log file. The assistant also never tries to add them again in normal running (but did add them when it was started again after a reboot).++What version of git-annex are you using? On what operating system?++git-annex version: 4.20130314+OS: Arch Linux++Please provide any additional information below.++The assistant in this case is being used as nothing more than a way for me to see which files have been added (--verbose, --foreground and --debug with 'watch' outputs nothing..). No remotes or anything like that.
+ doc/bugs/assistant_hangs_during_commit.mdwn view
@@ -0,0 +1,27 @@+[[!meta title="on Arch Linux, git commit -m tries to run an editor on the commit message"]]++What steps will reproduce the problem?++Use git-annex and add file to repo.+++What is the expected output? What do you see instead?++File is committed and added to annex.++Instead a command like this is run "git --git-dir=/home/jchu/annex/.git --work-tree=/home/jchu/annex commit --allow-empty-message -m  --quiet" and for some reason git decides to open a COMMIT_EDITMSG file in my editor of choice "vim .git/COMMIT_EDITMSG".  Since git annex doesn't give me access to the terminal, I don't see it.++Depending on when it happens, the web interface could refuse to start (if the commit hang happens on startup) or if it happens during regular operation, then everything looks fine but the web interface doesn't update after that.+++What version of git-annex are you using? On what operating system?++git-annex (binary release) 4.20130405+git 1.8.2.1++On Arch Linux.+++Please provide any additional information below.++I'm not sure if the git interface has changed, but I do see that --allow-empty-message does still exist.  If I run the git commit command (with a '' after the -m), it does indeed start up vim for me.  Would we benefit from just making a custom commit message ("Commit from date YYYYMMDDTHHMMSSZ")?
doc/bugs/git-annex_add_should_repack_as_it_goes.mdwn view
@@ -22,3 +22,11 @@ (Mac OS 10.8.3)  git version 1.8.2++> Based on the benchmarks below, repacking even once does not speed things+> up; repacking repeatedly as `git annex add` runs would slow things down.+> +> It might be worth following up with the git developers why `git commit`+> scans loose objects after it has already output the commit sha1sum.+> +> Don't see any improvements git-annex can make. [[done]] --[[Joey]]
+ doc/bugs/git-annex_thinks_files_are_in_repositories_they_are_not.mdwn view
@@ -0,0 +1,22 @@+###What steps will reproduce the problem?++1. Start git annex webapp, and make new repository on two computers.+1. Pair them as "Local computer"s, and they synchronize fine, a file created on one shows up on the other.+1. Disconnect one of the computers from the network, and create a new file+1. Check where the file is.++###What is the expected output? What do you see instead?++    git annex whereis new file++shows the file being in both repositories, when in fact it has had no chance to get added to the one on the other computer, and is not in it.+++###What version of git-annex are you using? On what operating system?++Both 4.20130405 on Ubuntu 12.10++###Please provide any additional information below.++I noticed this first when using a USB drive to communicate between work and home. Making changes at home, it thought that the new files were now present at work, when the computer there is off, and a long way away.+--Walter
+ doc/bugs/git_annex_fsck_in_direct_mode_does_not_checksum_files.mdwn view
@@ -0,0 +1,18 @@+What steps will reproduce the problem?++Put some large files into a direct mode repository (so fsck time is noticeable).  git annex add them, commit, run git annex fsck.++What is the expected output? What do you see instead?++Expected: files are checksummed, which should take considerable amount of time for each file.  For reference, in indirect mode, fsck takes a while for files of ~1GB size.+Actually: in direct mode, git annex fsck goes through all of the files in an instant and prints OK for each. I believe the file content is not verified.+Multiple runs of git annex fsck do the same thing.++What version of git-annex are you using? On what operating system?++git-annex version: 4.20130405, Linux++Please provide any additional information below.++> I've fixed it, fsck is indeed checksumming direct mode files now, as long+> as they're not known to be modified. [[done]] --[[Joey]]
doc/contact.mdwn view
@@ -1,11 +1,11 @@ Joey Hess <joey@kitenet.net> is the author of git-annex. If you need to-talk about something privatly, email me.+talk about something privately, email me.  The [[forum]] is the best place to discuss git-annex. +For realtime chat, use the `#git-annex` channel on irc.oftc.net.+You can also watch incoming commits there.+ The [VCS-home mailing list](http://lists.madduck.net/listinfo/vcs-home) is a good mailing list for users who want to use git-annex in the context of managing their large personal files.--For realtime chat, use the `#vcs-home` channel on irc.oftc.net.-You can also watch incoming commits there.
+ doc/design/assistant/blog/day_230__Mom.mdwn view
@@ -0,0 +1,35 @@+Made a release today. Releasing has sure gotten easier with all the+autobuilds to use!++I am now using git-annex to share files with my mom. Here's how the webapp+looks for our family's repository. Soon several of us will be using this+repository.++[[!img assistant/example.png]]++We're using XMPP and rsync.net, so pretty standard setup much like+shown in my last screencast.++Real-world deployments help find bugs, and I found a few:++* If you're running the webapp in `w3m` on a remote computer to set it up,+  some forms are lacking submit buttons. This must be a issue with+  Bootstrap, or HTML5, I guess. I switched to `lynx` and it offers a+  way to submit forms that lack an explicit button.++* Progress bars for downloads from encrypted rsync repos don't update+  during the actual download, but only when gpg is decrypting the+  downloaded file.++* XMPP pushes sometimes fail still. Especially when your mom's computer+  is saturating its limited outgoing network connection uploading hundreds of+  photos. I have not yet determined if this is a packet loss/corruption issue,+  or if the XMPP messages are getting out of order. My gut feeling is it's+  the latter, in which can I can fix this pretty easily by adding sequence+  numbers and some buffering for out of order packets. Or perhaps just+  make it retry failed pushes when this happens.+  +  Anyway, I found it was useful to set up a regular git repository on a+  server to suppliment the git pushes over XMPP. It's helpful to have+  such a git repository anyway, so that clients can push to there when the+  other client(s) are not online to be pushed to directly over XMPP.
+ doc/design/assistant/blog/day_231__insert_title.mdwn view
@@ -0,0 +1,26 @@+Finally fixed the bug causing repeated checksumming when a direct mode file+contains duplicate files. I may need to add some cleaning of stale inode+caches eventually.++Meanwhile, Guilhem made `git annex initremote` use higher quality entropy,+with `--fast` getting back to the old behavior of urandom quality entropy.+The assistant doesn't use high quality entropy since I have no way to+prompt when the user would need to generate more. I did have a fun idea to+deal with this: Make a javascript game, that the user can play while+waiting, which would generate enropy nicely. Maybe one day.. ;)++Also made a small but significant change to [[archive directory handling|todo/assistant_smarter_archive_directory_handling]].+Now the assistant syncs files that are in `archive` directories like any+other file, until they reach an archive repository. Then they get dropped+from all the clients. This way, users who don't set up archive repositories+don't need to know about this special case, and users who do want to use+them can, with no extra configuration.++After recent changes, the preferred content expression for transfer+repositories is becoming a bit unweidly, at 212 characters. Probably+time to add support for macros..++`(not (inallgroup=client and copies=client:2) and (((exclude=*/archive/* and exclude=archive/*) or (not (copies=archive:1 or copies=smallarchive:1))) or (not copies=semitrusted+:1))) or (not copies=semitrusted+:1)`++Still, it's pretty great how much this little language lets me express, so+easily.
+ doc/design/assistant/blog/day_232__headless_webapp.mdwn view
@@ -0,0 +1,22 @@+Developed a way to run the webapp on a remote or headless computer.++The webapp can now be started on a remote or headless computer, just+specify `--listen=address` to make it listen on an address other than+localhost. It'll print out the URL to open to access it.++This doesn't use HTTPS yet, because it'd need to generate a+certificate, and even if it generated a self-signed SSL certificate,+there'd be no easy way for the browser to verify it and avoid a MITM.++So `--listen` is a less secure but easier option; using ssh to forward+the webapp's port to the remote computer is more secure.++(I do have an idea for a way to do this entirely securely, making+the webapp set up the ssh port forwarding, which I have written down+in [[webapp]].. but it would be rather complicated to implement.)++----++Made the webapp rescan for transfers after it's been used to change a+repository's group. Would have been easy, but I had to chase down a+cache invalidation bug.
+ doc/design/assistant/blog/day_233__taxes.mdwn view
@@ -0,0 +1,11 @@+Did my taxes today. Not very pretty. Planning to run them by a professional.++Reproduced a bug that prevents git-annex from authenticating to the ejabberd+server, and passed the buck upstream with a test case to the author of the+haskell XMPP library.++Added some animations to the webapp to show when it's busy doing things.++Made `git annex webapp --listen=address:port` work.++Added a `annex.web-download-command` setting.
+ doc/design/assistant/blog/day_234__clean_shutdown.mdwn view
@@ -0,0 +1,29 @@+Short day because I spent 3 hours this morning explaining free software+and kickstarter to an accountant. And was away until 3 pm, so how did I get+all this done‽++Eliot pointed out that shutting down the assistant could leave transfers+running. This happened because `git annex transferkeys` is a separate+process, and so it was left to finish up any transfer that was in+process. I've made shutdown stop all transfers that the+assistant started. (Other paired computers could still be connecting to+make transfers even when the assistant is not running, and those are not+affected.)++Added sequence numbers to the XMPP messages used for git pushes. While+these numbers are not used yet, they're available for debugging, and will+help me determine if packets are lost or come out of order. So if you have+experienced problems with XMPP syncing sometimes failing, run tonight's+build of the assistant with `--debug` (or turn on debugging in the webapp+configuration screen), and send me a log by email to+<debuglogs201204@joeyh.name>++Changed the way that autobuilds and manual builds report their version+number. It now includes the date of the last commit, and the abbreviated+commit ID, rather than being some random date after the last release.++Frederik found a bug using the assistant on a FAT filesystem. It didn't+properly handle the files that git uses to stand-in for symlinks in that+situation, and annexed those files. I've fixed this, and even moving+around symlink stand-in files on a FAT filesystem now results in correct+changes to symlinks being committed.
+ doc/design/assistant/blog/day_235__birthday.mdwn view
@@ -0,0 +1,31 @@+Felt like spending my birthday working on git-annex. Thanks again to+everyone who makes it possible for me to work on something I care about+every day.++----++Did some work on `git annex addurl` today. It had gotten broken in direct+mode (I think by an otherwise good and important bugfix). After fixing+that, I made it interoperate with the webapp. So if you have the webapp+open, it will display progress bars for downloads being run by `git annex+addurl`.++This enhancement meshes nicely with a FlashGot script Andy+contributed, which lets you queue up downloads into your annex from a web+browser. Andy described how to set it up in+[[this_tip|tips/Using_Git-annex_as_a_web_browsing_assistant]].++(I also looked briefly into ways to intercept a drag and drop of a link+into the webapp and make it lauch a download for you. It doesn't seem that+browsers allow javascript to override their standard behavior of loading+links that are dropped into them. Probably good to prevent misuse, but it+would be nice here...)++----++Also, I think I have fixed the progress bars displayed when downloading+a file from an encrypted remote. I did this by hooking up existing+download progress metering (that was only being used to display+a download percentage in the console) into the location log, so the+webapp can use it. So that was a *lot* easier than it could have been,+but still a pretty large patch (500+ lines). Haven't tested this; should work.
+ doc/design/assistant/blog/day_236__evil_splicer.mdwn view
@@ -0,0 +1,29 @@+Spent today bulding the Evil Splicer, a program that parses `ghc -ddump-splices`+output, and uses it to expand Template Haskell splices in source code.+I hope to use this crazy hack to get the webapp working on Android.++This was a good opportunity to use the+[Parsec](http://hackage.haskell.org/package/parsec) library for parsing the+ghc output. I've never really used it before, but found it quite nice to+work with. The learning curve, if you already know monads and applicatives,+is about 5 minutes. And instead of ugly regular expressions, you can work+with nice code that's easily composable and refactorable. Even the ugly+bits come out well:++[[!format haskell """+	{- All lines of the splice result will start with the same+	- indent, which is stripped. Any other indentation is preserved. -}+	i <- lookAhead indent+	result <- unlines <$> many1 (string i >> restOfLine)+"""]]++Anyway, it works.. sorta. The parser works great! The splices that ghc+outputs are put into the right places in the source files, and formatted in+a way that ghc is able to build. Often though, they contain code that+doesn't actually build as-is. I'm working to fix up the code to get closer+to buildable.++----++Meanwhile, guilhem has made ssh connection caching work for rsync special+remotes! It's very nice to have another developer working on git-annex. :)
+ doc/design/assistant/blog/day_237__gnome-keyring_craziness.mdwn view
@@ -0,0 +1,29 @@+Fixed a bug where the locked down ssh key that the assistant sets up to+access the annex on a remote server was being used by ssh *by default* for+all logins to that server.++That should not have happened. The locked down key is written to a filename+that ssh won't use at all, by default. But, I found code in gnome-keyring+that watches for `~/.ssh/*.pub` to appear, and automatically adds all such+keys to the keyring. In at least some cases, probably when it has no other+key, it then tells ssh to go ahead and use that key. Astounding.++To avoid this, the assistant will store its keys in <s>`~/.ssh/annex/`</s>+`~/.ssh/git-annex/` instead. gnome-keyring does not look there (verified in+the source). If you use gnome-keyring and have set up a repository on a+remote server with the assistant, I'd recommend moving the keys it set up+and editing `~/.ssh/config` to point to their new location.++gnome-keyring is not the only piece of software that has a bad+interaction with git-annex. I've been working on a bug that makes git-annex+fail to authenticate to ejabberd. ejabberd 2.1.10 got support for+SCRAM-SHA-1, but its code violates the RFC, and chokes on an address+attribute that the haskell XMPP library provides. I hope to get this fixed+in ejabberd.+++Also did some more work on the Evil Splicer today, integrating it into the+build of the Android app, and making it support incremental building.+Improved its code generation, and am at the milestone where it creates+valid haskell code for the entire `Assistant/WebApp/Types.hs` file,+where Template Haskell expands 2 lines into 2300 lines of code!
+ doc/design/assistant/blog/day_238__back_to_Android.mdwn view
@@ -0,0 +1,11 @@+Back to really working toward an Android webapp now. I have been improving+the EvilSplicer, and the build machinery, and build environment all day.+Slow but steady progress.++First milestone of the day was when I got `yesod-form` to build with all+Template Haskell automatically expanded by the EvilSplicer. (With a few+manual fixups where it's buggy.)++At this point the Android build with the webapp enabled successfully+builds several files containing Yesod code.. And I suspect I am very close+to getting a first webapp build for Android.
+ doc/design/assistant/blog/day_239__bugfixes_and_frustration.mdwn view
@@ -0,0 +1,28 @@+Several bug fixes today, and got mostly caught up on recent messages.+Still have a backlog of two known bugs that I cannot reproduce well enough+to have worked on, but I am thinking I will make a release tomorrow. There+have been a lot of changes in the 10 days since the last release.++----++I am, frustratingly, stuck building the webapp on Android with no forward+progress today (and last night) after such a productive day yesterday.++The expanded Template Haskell code of the webapp fails to compile,+whereever type safe urls are used.++<pre>+Assistant/WebApp/Types.hs:95:63:+    Couldn't match expected type `Route WebApp -> t2'+                with actual type `Text'+    The function `urender_a1qcK' is applied to three arguments,+    but its type `Route WebApp -> [(Text, Text)] -> Text' has only two+    In the expression: urender_a1qcK u_a1qcL [] LogR+    In the first argument of `toHtml', namely+      `(\ u_a1qcL -> urender_a1qcK u_a1qcL [] LogR)'+</pre>++My best guess is this is a mismatch between the versions of yesod (or other+libraries) used for the native and cross compiled ghc's. So I've been+slowly trying to get a fully matched set of versions in between working on+bugs.
doc/design/assistant/progressbars.mdwn view
@@ -12,6 +12,33 @@ * Watch temp file as it's coming in and use its size.   Can either poll every .5 seconds or so to check file size, or   could use inotify. **done**+* When easily available, remotes call the MeterUpdate callback as uploads+  progress. **done**++* TODO a bad interaction can happen between the TransferPoller and the+  TransferWatcher when downloading from an encrypted remote. If+  a partially transferred file exists already, in the gitAnnexTmpLocation+  of the (un-encrypted) key, the TransferPoller will trust it to have+  the right size of the content downloaded. This will stomp, every 0.5+  seconds, over the updates to the size that the TransferWatcher is seeing+  in the transfer log files.++  We still need the TransferPoller for the remotes that don't have+  download meters. This includes git, web, bup, and hook.++  Need to teach the TransferPoller to detect when transfer logs for downloads+  have file size info, and use it, rather than looking at the temp file.+  The question is, how to do this efficiently? It could just poll the+  transfer log every time, and if size is nonzero, ignore the temp file.+  This would work, but it would require a lot more work than the simple+  statting of the file it does now. And this runs every 0.5 seconds.++  I could try to convert all remotes I care about to having progress+  for downloads. But converting the web special remote will be hard..++  I think perhaps the best solution is to make the TransferWatcher also watch+  the temp files. Then if one changes, it can get its new size. If a+  transfer info file changes, it can get the size from there.  ## uploads
doc/design/assistant/webapp.mdwn view
@@ -26,6 +26,22 @@ * allow disabling syncing to here, which should temporarily disable all   local syncing. **done** +## better headless support++`--listen` is insecure, and using HTTPS would still not make it 100% secure+as there would be no way for the browser to verify its certificate.++I do have a better idea, but it'd be hard to implement.+`git annex webapp --remote user@host:dir` could ssh to the remote host,+run the webapp there, listening only on localhost, and then send the+port the webapp chose back over the ssh connection. Then the same+ssh connection could be reused (using ssh connection caching) to set up+port forwarding from a port on the local host to the remote webapp.++This would need to handle the first run case too, which would require+forwarding a second port once the webapp made the repository and+the second webapp started up.+ ## first start **done**  * make git repo **done**
doc/design/assistant/xmpp.mdwn view
@@ -88,16 +88,21 @@ The receiver runs `git receive-pack`, and sends back its output in one or more chat messages, directed to the client that is pushing: -	<git-annex xmlns='git-annex' rp="">+	<git-annex xmlns='git-annex' rp="N"> 	007b27ca394d26a05d9b6beefa1b07da456caa2157d7 refs/heads/git-annex report-status delete-refs side-band-64k quiet ofs-delta 	</git-annex>  The sender replies with the data from `git push`, in  one or more chat messages, directed to the receiver: -	<git-annex xmlns='git-annex' sp="">+	<git-annex xmlns='git-annex' sp="N"> 	data 	</git-annex>++The value of rp and sp used to be empty, but now it's a sequence number.+This indicates the sequence of this packet, counting from 1. The receiver+and sender each have their own sequence numbers. These sequence numbers+are not really used yet, but are available for debugging.  When `git receive-pack` exits, the receiver indicates its exit status with a chat message, directed at the sender:
doc/design/encryption.mdwn view
@@ -23,10 +23,15 @@ [for Obnam](http://liw.fi/obnam/encryption/). """]] -Data is encrypted by gpg, using a symmetric cipher.-The cipher is itself checked into your git repository, encrypted using one or-more gpg public keys. This scheme allows new gpg private keys to be given-access to content that has already been stored in the remote.+Data is encrypted by GnuPG, using a symmetric cipher. The cipher is+generated by GnuPG when the special remote is created. By default the+best entropy pool is used, hence the generation may take a while; One+can use `initremote` with `highRandomQuality=false` or `--fast` options+to speed up things, but at the expense of using random numbers of a+lower quality. The generated cipher is then checked into your git+repository, encrypted using one or more OpenPGP public keys. This scheme+allows new OpenPGP private keys to be given access to content that has+already been stored in the remote.  Different encrypted remotes need to be able to each use different ciphers. Allowing multiple ciphers to be used within a single remote would add a lot
+ doc/forum/Add_a___34__local__34___remote.txt view
@@ -0,0 +1,13 @@+I have been playing around with annex assistent today (way late as I am one of the Kickstarter backers) and found the following puzzling.++I am running a fairly new version, my package manager calls it 4.20130323 (git-annex does not seem to have a --version switch). ++I have been playing around with the annex assistent webapp today and have the following questions/observations: ++1) The "remote" server creates a bare git repository as far as I can tell, the "local computer" probably does the right thing (but I cannot run it as the "other box" has no X or browser). Is there any way to remotely create a "local" copy (i.e. non-bare git repository, which can later be managed by the cli?)+2) It seems like git-annex-assistent (webapp) binds to localhost, is it possible to let it bind to either a specific ip-address (or all)? (Yes, I understand the security implications, but the use-case is the box from question 2 - i.e. on local network but no X and no browser). +3) what is being launched when I hit "files", on the video it starts a file-manager on my box nothing happens (and no errors as far as I can tell). ++Thank you in advance++Svenne
+ doc/forum/Drop_with_assistant.mdwn view
@@ -0,0 +1,5 @@+Hi,++how can I handle *drop* with the assistant? There are some files in my annex that I don't need on my laptop. so i just *drop* them on the command line bevcause I have copies on my server and an external usb drive. But after a while the assistant pulls all the files back in. Can I avoid this and make the *drop* somehow "sticky" until i *get* them over cli?++Best, Michael
+ doc/forum/Same_Jabber_account_for_different_annexes.mdwn view
@@ -0,0 +1,1 @@+Is it possible to use the same jabber account for different annexes? I think I've mixed up several repositories by using the same jabber account for synchronizing...
+ doc/forum/Transfer_remotes.mdwn view
@@ -0,0 +1,3 @@+Hi!++I have a laptop A on which I setup a box.com special remote as a transfer encrypted repository. It is quite unclear to me how I should configure laptop B to use the same box.com remote and share files between the two machines.
+ doc/forum/XMPP_authentication_failure.mdwn view
@@ -0,0 +1,15 @@+Hi,++Not sure if this is a bug or not, so posting it here rather than in the bug tracker.++Basically, I am unable to add an XMPP identity via the webapp, I continually  get the error message: "Unable to connect to the Jabber server. Maybe you entered the wrong password? (Error message: AuthenticationFailure)"++I didn't enter the wrong password, I copy/pasted it from my password manager and the same account/password work fine with Pidgin. The log doesn't show anything of interest that I can see.++Using git annex version 4.20130405 from Debain Unstable. The server is ejabberd running on my VPS with a self signed certificate.++Anyone got any idea what might be going on?++Cheers,++Rob
+ doc/forum/wishlist:_get__47__drop_via_webapp_file_explorer.mdwn view
@@ -0,0 +1,1 @@+Know what'd be a sweet feature?  A file explorer in the webapp that lets you get and drop files (for a Manual local repository).  Especially when the webapp becomes available on Android.  I'd love to be able to select what is and isn't present on a small device by some means other than moving files around.
doc/git-annex.mdwn view
@@ -198,9 +198,18 @@  * webapp -  Runs a web app, that allows easy setup of a git-annex repository,+  Opens a web app, that allows easy setup of a git-annex repository,   and control of the git-annex assistant. +  By default, the webapp can only be accessed from localhost, and running+  it opens a browser window.++  With the --listen=address[:port] option, the webapp can be made to listen+  for connections on the specified address. This disables running a+  local web browser, and outputs the url you can use to open the webapp+  from a remote computer.+  Note that this does not yet use HTTPS for security, so use with caution!+ # REPOSITORY SETUP COMMANDS  * init [description]@@ -934,6 +943,15 @@   to or from this remote. For example, to force ipv6, and limit   the bandwidth to 100Kbyte/s, set it to "-6 --bwlimit 100" +* `remote.<name>.annex-rsync-transport`++  The remote shell to use to connect to the rsync remote. Possible+  values are `ssh` (the default) and `rsh`, together with their+  arguments, for instance `ssh -p 2222 -c blowfish`; Note that the+  remote hostname should not appear there, see rsync(1) for details.+  When the transport used is `ssh`, connections are automatically cached+  unless `annex.sshcaching` is unset.+ * `remote.<name>.annex-bup-split-options`    Options to pass to bup split when storing content in this remote.@@ -957,7 +975,7 @@ * `annex.web-options`    Options to use when using wget or curl to download a file from the web.-  (wget is always used in preference to curl if available).+  (wget is always used in preference to curl if available.)   For example, to force ipv4 only, set it to "-4"  * `annex.http-headers`@@ -969,6 +987,16 @@    If set, the command is run and each line of its output is used as a HTTP   header. This overrides annex.http-headers.++* `annex.web-download-command`++  Use to specify a command to run to download a file from the web.+  (The default is to use wget or curl.)++  In the command line, %url is replaced with the url to download,+  and %file is replaced with the file that it should be saved to.+  Note that both these values will automatically be quoted, since+  the command is run in a shell.  * `remote.<name>.rsyncurl`
doc/install/Linux_standalone.mdwn view
@@ -24,3 +24,10 @@  * i386: [download tarball](http://downloads.kitenet.net/git-annex/autobuild/i386/git-annex-standalone-i386.tar.gz) ([build logs](http://downloads.kitenet.net/git-annex/autobuild/i386/)) * amd64: [download tarball](http://downloads.kitenet.net/git-annex/autobuild/amd64/git-annex-standalone-amd64.tar.gz) ([build logs](http://downloads.kitenet.net/git-annex/autobuild/amd64/))++## gitannex-install++Eskild Hustvedt has contributed a+[gitannex-install](https://github.com/zerodogg/scriptbucket/blob/master/gitannex-install)+script to manage keeping up to date with new releases using the standalone+built.
+ doc/install/OSX/comment_16_1befafa862b7d07b1f6e57c0182497cf._comment view
@@ -0,0 +1,36 @@+[[!comment format=mdwn+ username="https://www.google.com/accounts/o8/id?id=AItOawkurjhi0CRJvgm7QNaZDWS9hitBtavqIpc"+ nickname="Bret"+ subject="Snow Leopard Issues"+ date="2013-04-14T20:17:17Z"+ content="""+I was able to build snow leopard completely for the first time over last night (it took a very long time to build all the tools and dependancies).  Woohoo!++The way I was able to fully build on a 32-bit 10.6 machine was this++1. Delete ~/.ghc and ~/.cabal.  They were full of random things and were causing problems.+2. `brew uninstall ghc and haskell-platform`+3. `brew update`+4. `brew install git ossp-uuid md5sha1sum coreutils libgsasl gnutls libidn libgsasl pkg-config libxml2`+5. `brew upgrade git ossp-uuid md5sha1sum coreutils libgsasl gnutls libidn libgsasl pkg-config libxml2` (Some of these were already installed/up to date.+6. `brew link libxml2`+7. `brew install haskell-platform`  (This takes a long, long time).+8. `cabal update` (assuming you have added `~/.cabal/bin` to your path+9. `cabal install cablal-install`+10. `cabal install c2hs`+11. `cabal install git-annex`+++It also appears to be running fairly smoothly than it had in the past on a 32-bit SL system.  Thats also neat.  ++The problem is that it seems to not really work as git annex though, probably due to the error relating you get when you start up the webapp:+Running+`git annex webapp` +The browser starts up, and I get 3 of these errors:+`Watcher crashed: Need at least OSX 10.7.0 for file-level FSEvents`++Pairing with a local computer appears to work to systems running 10.7, but when you complete the process, they never show up in the repository list.+++Also on a side note, when running `git annex webapp` it triggers the opening of an html file in whatever the default html file handler is.  I edit a lot of html, so for me that is usually a text editor.  I had to change the file handler to open html files with my web browser for the `git annex webapp` to actually work.  Is there a way to change that so that `git annex webapp` uses the default web browser for the system rather than the default html file handler?+"""]]
+ doc/install/OSX/comment_17_19c08b2c6c2c5cd88bf96d2bcbbd9055._comment view
@@ -0,0 +1,10 @@+[[!comment format=mdwn+ username="http://joeyh.name/"+ nickname="joey"+ subject="comment 17"+ date="2013-04-16T20:31:10Z"+ content="""+@Bret, the assistant relies on FSEvents pretty heavily. It seems to me your best bet is to upgrade OSX to a version that supports FSEvents.++You can certainly use the rest of git-annex on Snow Leopard without FSEvents.+"""]]
doc/install/fromscratch.mdwn view
@@ -46,6 +46,7 @@   * [dns](http://hackage.haskell.org/package/dns)   * [xml-types](http://hackage.haskell.org/package/xml-types)   * [async](http://hackage.haskell.org/package/async)+  * [HTTP](http://hackage.haskell.org/package/HTTP) * Shell commands   * [git](http://git-scm.com/)   * [xargs](http://savannah.gnu.org/projects/findutils/)
− doc/news/version_3.20130216.mdwn 
@@ -1,17 +0,0 @@-git-annex 3.20130216 released with [[!toggle text="these changes"]]-[[!toggleable text="""-   * Now uses the Haskell uuid library, rather than needing a uuid program.-   * Now uses the Haskell Glob library, rather than pcre-light, avoiding-     the need to install libpcre. Currently done only for Cabal or when-     the Makefile is made to use -DWITH\_GLOB-   * Android port now available (command-line only).-   * New annex.crippledfilesystem setting, allows use of git-annex-     repositories on FAT and even worse filesystems; avoiding use of-     hard links and locked down permissions settings. (Support is incomplete.)-   * init: Detect when the repository is on a filesystem that does not-     support hard links, or symlinks, or unix permissions, and set-     annex.crippledfilesystem, as well as annex.direct.-   * add: Improved detection of files that are modified while being added.-   * Fix a bug in direct mode, introduced in the previous release, where-     if a file was dropped and then got back, it would be stored in indirect-     mode."""]]
+ doc/news/version_4.20130417.mdwn view
@@ -0,0 +1,44 @@+git-annex 4.20130417 released with [[!toggle text="these changes"]]+[[!toggleable text="""+   * initremote: Generates encryption keys with high quality entropy.+     This can be disabled using --fast to get the old behavior.+     The assistant still uses low-quality entropy when creating encrypted+     remotes, to avoid delays. (Thanks, guilhem for the patch.)+   * Bugfix: Direct mode no longer repeatedly checksums duplicated files.+   * assistant: Work around horrible, terrible, very bad behavior of+     gnome-keyring, by not storing special-purpose ssh keys in ~/.ssh/*.pub.+     Apparently gnome-keyring apparently will load and indiscriminately use+     such keys in some cases, even if they are not using any of the standard+     ssh key names. Instead store the keys in ~/.ssh/annex/,+     which gnome-keyring will not check.+   * addurl: Bugfix: Did not properly add file in direct mode.+   * assistant: Bug fix to avoid annexing the files that git uses+     to stand in for symlinks on FAT and other filesystem not supporting+     symlinks.+   * Adjust preferred content expressions so that content in archive+     directories is preferred until it has reached an archive or smallarchive+     repository.+   * webapp: New --listen= option allows running the webapp on one computer+     and connecting to it from another. (Note: Does not yet use HTTPS.)+   * Added annex.web-download-command setting.+   * Added per-remote annex-rsync-transport option. (guilhem again)+   * Ssh connection caching is now also used by rsync special remotes.+     (guilhem yet again)+   * The version number is now derived from git, unless built with+     VERSION\_FROM\_CHANGELOG.+   * assistant: Stop any transfers the assistant initiated on shutdown.+   * assistant: Added sequence numbers to XMPP git push packets. (Not yet used.)+   * addurl: Register transfer so the webapp can see it.+   * addurl: Automatically retry downloads that fail, as long as some+     additional content was downloaded.+   * webapp: Much improved progress bar display for downloads from encrypted+     remotes.+   * Avoid using runghc, as that needs ghci.+   * webapp: When a repository's group is changed, rescan for transfers.+   * webapp: Added animations.+   * webapp: Include the repository directory in the mangled hostname and+     ssh key name, so that a locked down ssh key for one repository is not+     re-used when setting up additional repositories on the same server.+   * Fall back to internal url downloader when built without curl.+   * fsck: Check content of direct mode files (only when the inode cache+     thinks they are unmodified)."""]]
doc/preferred_content.mdwn view
@@ -86,9 +86,10 @@  ### client -All content is preferred, unless it's in a "archive" directory.+All content is preferred, unless it's for a file in a "archive" directory,+which has reached an archive repository. -`(exclude=*/archive/* and exclude=archive/*) or (not copies=semitrusted+:1)`+`((exclude=*/archive/* and exclude=archive/*) or (not (copies=archive:1 or copies=smallarchive:1))) or (not copies=semitrusted+:1)`  ### transfer @@ -100,7 +101,7 @@ The preferred content expression for these causes them to get and retain data until all clients have a copy. -`(not (inallgroup=client and copies=client:2) and exclude=*/archive/* and exclude=archive/*) or (not copies=semitrusted+:1)`+`(not (inallgroup=client and copies=client:2) and ($client)`  The "copies=client:2" part of the above handles the case where there is only one client repository. It makes a transfer repository@@ -152,15 +153,18 @@  ### manual -This gives you full manual control over what content is stored in the+This gives you nearly full manual control over what content is stored in the repository. This allows using the [[assistant]] without it trying to keep a local copy of every file. Instead, you can manually run `git annex get`,-`git annex drop`, etc to manage content.+`git annex drop`, etc to manage content. Only content that is present+is preferred. -Only content that is present is preferred. Content in "archive"-directories is never preferred.+The exception to this manual control is that content that a client+repository would not want is not preferred. So, files in archive+directories are not preferred once their content has +reached an archive repository. -`(present and exclude=*/archive/* and exclude=archive/*) or (not copies=semitrusted+:1)`+`present and ($client)`  ### unwanted
+ doc/special_remotes/comment_11_e01b5cc5a0d81b071e93e27e7b91fe2a._comment view
@@ -0,0 +1,8 @@+[[!comment format=mdwn+ username="andy"+ ip="99.48.75.171"+ subject="Re: Webhook special remote"+ date="2013-04-12T08:54:47Z"+ content="""+@Alex: You might see if the newly-added [[todo/wishlist: allow configuration of downloader for addurl]] could be made to do what you need... I've not played around with it yet, but perhaps you could set the downloader to be something that can sort out the various URLs and send them to the correct downloading tool?+"""]]
+ doc/special_remotes/xmpp/comment_1_568247938929a2934e8198fca80b7184._comment view
@@ -0,0 +1,11 @@+[[!comment format=mdwn+ username="https://www.google.com/accounts/o8/id?id=AItOawmWg4VvDTer9f49Y3z-R0AH16P4d1ygotA"+ nickname="Tobias"+ subject="User defined server"+ date="2013-04-17T09:45:59Z"+ content="""+It would be nice if you could expand the XMPP setup in the assistant to support an \"advanced\" settings view where a custom server could be defined.++Example: I have a google Apps domain called mytest.com, with the users bla1@mytest.com and bla2@mytest.com. When trying to add either of those accounts to the assistant XMPP will try to use mytest.com as the jabber server, and not googles server.++"""]]
+ doc/tips/Using_Git-annex_as_a_web_browsing_assistant.mdwn view
@@ -0,0 +1,46 @@+[[todo/wishlist: an "assistant" for web-browsing -- tracking the sources of the downloads]] suggests using git-annex as a tool to store downloads tied+to their URLs. This also enables people to have their files stored offline,+while being able to git annex drop them at any time and redownload them+with git annex get. Additionally, a clone of the repo can be used to+download whatever files are desired from online.++This tip explains how to implement a similar system to the one described in+the linked wishlist with existing software and features of git-annex.++The first step is to install the Firefox plugin+[FlashGot](http://flashgot.net/). We will use it to provide the Firefox+shortcuts to add things to our annex.++We also need a normal download manager, if we want to get status updates as+the download is done. We'll need to configure git-annex to use it by+setting `annex.web-download-command` as Joey describes in his comment on+[[todo/wishlist: allow configuration of downloader for addurl]]. See the+manpage [[git-annex]] for more information on setting configuration.++Once we have installed all that, we need a script that has an interface+which FlashGot can treat as a downloader, but which calls git-annex to do+the actual downloading. Such a script is available from+<https://gist.github.com/andyg0808/5342434>. Download it and store it+somewhere it can live, or cut and paste:++[[!format sh """+#!/bin/bash+# $1=folder to cd to (must be a git annex repo)+# $2=URL to download++cd "$1"+git-annex addurl "$2"+"""]]++Finally, we need to configure FlashGot to use the script as a downloader.+Go to Tools > Add-ons in Firefox. Click "Preferences" on FlashGot. Click+the Add button next to the list of download managers. Enter a name for the+git-annex downloader. Choose the script that was downloaded from the+"Locate executable file" dialog that appears. Now set the command line+arguments template to be "[FOLDER] [URL]" (you can find more substitution+expressions in the Placeholders dropdown above the Command line arguments+template field). You're done!++Go ahead and test it by trying to download a file using FlashGot. It should+offer as one of its available download managers the new manager you created+just above. Select it and have fun!
+ doc/todo/assistant_smarter_archive_directory_handling.mdwn view
@@ -0,0 +1,31 @@+Client repos do not want files in archive directories. This can turn+out to be confusing to users who are using archive directories for their+own purposes and not aware of this special case in the assistant. It can+seem like the assistant is failing to sync their files.++I thought, first, that it should have a checkbox to enable the archive+directory behavior.++However, I think I have a better idea. Change the preferred content+expression for clients, so they want files in archive directories, *until*+those files land in an archive.++This way, only users who set up an archive repo get this behavior. And they+asked for it by setting up that repo!++Also, the new behavior will mean that files in archive directories still+propigate around to clients. Consider this topology:++	client A ---- client B ---- archive++If a file is created in client A, and moved to an archive directory before+it syncs to B, it will never get to the archive, and will continue wasting+space on A. With the new behavior, A and B serve as effectively, transfer+repositories for archived content.++Something vaguely like this should work as the preferred content+expression for the clients:++	exclude=archive/* or (include=archive/* and (not (copies=archive:1 or copies=smallarchive:1)))++> [[done]] --[[Joey]]
doc/todo/optinally_transfer_file_unencryptedly.mdwn view
@@ -1,3 +1,6 @@ I have a git-annex repository on a NSLU 2, and transfers are much slower over ssh compared to unencrypted transfers (no wonder at that CPU speed). For the files that I am transferring, no encryption would be necessary. Unfortunately, ssh in Debian does not support "-c none" to disable encryption.  It would be nice if git-annex would have a way of conveniently transferring files in another way than SSH. I’m not sure what a good way would be – maybe launching a one-shot HTTP-server on the sending end? Haskell libraries for that would be available... Of course it is not always the case that the host reachable with "ssh foo" is also reachable via TCP at "foo:1234"... And there are surely more problem. But still, it would be nice :-)++> Setting `remote.name.annex-rsync-transport = rsh` will now+> make rsync special remotes use rsh instead of ssh. [[done]]
+ doc/todo/wishlist:_allow_configuration_of_downloader_for_addurl.mdwn view
@@ -0,0 +1,3 @@+It would be neat if Git annex addurl allowed a configuration option for a download manager command to do the actual download in place of wget/curl with a placeholder for the file name to save to & URL to get from (if that's all annex needs). That would allow the user to choose a graphical download manager if desired to make progress easier to monitor. The specific circumstance I'm seeing is with [[wishlist:_an___34__assistant__34___for_web-browsing_--_tracking_the_sources_of_the_downloads]]. I found that the existing Firefox addon [FlashGot](http://flashgot.net/) can run any command with arbitrary arguments including placeholders. Right now I've got a [script](https://gist.github.com/andyg0808/5342434) that changes to a user-selected directory and then runs git-annex addurl in it with the provided url. It works fine as a download manager for FlashGot. The issue is that there is no progress information for large file downloads. If git-annex could start a separate download manager to do the actual download, then the user would be able to check status at any time, even though the git-annex command was run from a GUI and not a terminal.++> [[done]], you can use `annex.web-download-command` now. --[[Joey]]
git-annex.1 view
@@ -180,9 +180,18 @@ it has created. These are listed in ~/.config/git\-annex/autostart .IP .IP "webapp"-Runs a web app, that allows easy setup of a git\-annex repository,+Opens a web app, that allows easy setup of a git\-annex repository, and control of the git\-annex assistant. .IP+By default, the webapp can only be accessed from localhost, and running+it opens a browser window.+.IP+With the \-\-listen=address[:port] option, the webapp can be made to listen+for connections on the specified address. This disables running a+local web browser, and outputs the url you can use to open the webapp+from a remote computer.+Note that this does not yet use HTTPS for security, so use with caution!+.IP .SH REPOSITORY SETUP COMMANDS .IP "init [description]" .IP@@ -821,6 +830,14 @@ to or from this remote. For example, to force ipv6, and limit the bandwidth to 100Kbyte/s, set it to "\-6 \-\-bwlimit 100" .IP+.IP "remote.<name>.annex\-rsync\-transport"+The remote shell to use to connect to the rsync remote. Possible+values are ssh (the default) and rsh, together with their+arguments, for instance ssh \-p 2222 \-c blowfish; Note that the+remote hostname should not appear there, see rsync(1) for details.+When the transport used is ssh, connections are automatically cached+unless annex.sshcaching is unset.+.IP .IP "remote.<name>.annex\-bup\-split\-options" Options to pass to bup split when storing content in this remote. For example, to limit the bandwidth to 100Kbyte/s, set it to "\-\-bwlimit 100k"@@ -841,7 +858,7 @@ .IP .IP "annex.web\-options" Options to use when using wget or curl to download a file from the web.-(wget is always used in preference to curl if available).+(wget is always used in preference to curl if available.) For example, to force ipv4 only, set it to "\-4" .IP .IP "annex.http\-headers"@@ -851,6 +868,15 @@ .IP "annex.http\-headers\-command" If set, the command is run and each line of its output is used as a HTTP header. This overrides annex.http\-headers.+.IP+.IP "annex.web\-download\-command"+Use to specify a command to run to download a file from the web.+(The default is to use wget or curl.)+.IP+In the command line, %url is replaced with the url to download,+and %file is replaced with the file that it should be saved to.+Note that both these values will automatically be quoted, since+the command is run in a shell. .IP .IP "remote.<name>.rsyncurl" Used by rsync special remotes, this configures
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 4.20130405+Version: 4.20130417 Cabal-Version: >= 1.8 License: GPL Maintainer: Joey Hess <joey@kitenet.net>@@ -66,7 +66,7 @@   Main-Is: git-annex.hs   Build-Depends: MissingH, hslogger, directory, filepath,    unix, containers, utf8-string, network (>= 2.0), mtl (>= 2),-   bytestring, old-locale, time,+   bytestring, old-locale, time, HTTP,    extensible-exceptions, dataenc, SHA, process, json,    base (>= 4.5 && < 4.8), monad-control, transformers-base, lifted-base,    IfElse, text, QuickCheck >= 2.1, bloomfilter, edit-distance, process,@@ -78,6 +78,7 @@   CC-Options: -Wall   GHC-Options: -threaded -Wall   CPP-Options: -DWITH_CLIBS+  Extensions: PackageImports    if flag(Production)     GHC-Options: -O2
standalone/android/Makefile view
@@ -32,7 +32,7 @@ 	# Install executables as pseudo-libraries so they will be 	# unpacked from the .apk. 	mkdir -p $(GIT_ANNEX_ANDROID_SOURCETREE)/term/libs/armeabi-	cp ../../git-annex $(GIT_ANNEX_ANDROID_SOURCETREE)/term/libs/armeabi/lib.git-annex.so+	cp ../../tmp/androidtree/git-annex $(GIT_ANNEX_ANDROID_SOURCETREE)/term/libs/armeabi/lib.git-annex.so 	cp $(GIT_ANNEX_ANDROID_SOURCETREE)/busybox/busybox $(GIT_ANNEX_ANDROID_SOURCETREE)/term/libs/armeabi/lib.busybox.so 	cp $(GIT_ANNEX_ANDROID_SOURCETREE)/openssh/ssh $(GIT_ANNEX_ANDROID_SOURCETREE)/term/libs/armeabi/lib.ssh.so 	cp $(GIT_ANNEX_ANDROID_SOURCETREE)/openssh/ssh-keygen $(GIT_ANNEX_ANDROID_SOURCETREE)/term/libs/armeabi/lib.ssh-keygen.so
+ standalone/android/evilsplicer-headers.hs view
@@ -0,0 +1,25 @@+++{- This file was modified by the EvilSplicer, adding these headers,+ - and expanding Template Haskell. + -+ - ** DO NOT COMMIT ** + -}+import qualified Data.Monoid+import qualified Data.Map+import qualified Data.Foldable+import qualified Data.Text+import qualified Data.Text.Lazy.Builder+import qualified Text.Shakespeare+import qualified Text.Hamlet+import qualified Text.Julius+import qualified Text.Css+import qualified "blaze-markup" Text.Blaze.Internal+import qualified Yesod.Widget+import qualified Yesod.Routes.TH.Types+import qualified Yesod.Routes.Dispatch+import qualified WaiAppStatic.Storage.Embedded+import qualified Data.FileEmbed+{- End EvilSplicer headers. -}++
− standalone/android/haskell-patches/hamlet-1.1.6.1_0001-axe-murdered.patch 
@@ -1,276 +0,0 @@-From 7be8bf3ba75acc5209066e6ba31ae589c541f344 Mon Sep 17 00:00:00 2001-From: Joey Hess <joey@kitenet.net>-Date: Thu, 28 Feb 2013 23:30:01 -0400-Subject: [PATCH] axe murdered------ Text/Hamlet.hs |  215 +-------------------------------------------------------- 1 file changed, 2 insertions(+), 213 deletions(-)--diff --git a/Text/Hamlet.hs b/Text/Hamlet.hs-index 4ac870a..bc8edd5 100644---- a/Text/Hamlet.hs-+++ b/Text/Hamlet.hs-@@ -11,35 +11,22 @@- module Text.Hamlet-     ( -- * Plain HTML-       Html--    , shamlet--    , shamletFile--    , xshamlet--    , xshamletFile-       -- * Hamlet-     , HtmlUrl--    , hamlet--    , hamletFile--    , xhamlet--    , xhamletFile-       -- * I18N Hamlet-     , HtmlUrlI18n--    , ihamlet--    , ihamletFile-       -- * Type classes-     , ToAttributes (..)-       -- * Internal, for making more-     , HamletSettings (..)-     , NewlineStyle (..)--    , hamletWithSettings--    , hamletFileWithSettings-     , defaultHamletSettings-     , xhtmlHamletSettings-     , Env (..)-     , HamletRules (..)--    , hamletRules--    , ihamletRules--    , htmlRules-     , CloseStyle (..)-+    , condH-+    , maybeH-     ) where- - import Text.Shakespeare.Base-@@ -90,14 +77,6 @@ type HtmlUrl url = Render url -> Html- -- | A function generating an 'Html' given a message translator and a URL rendering function.- type HtmlUrlI18n msg url = Translate msg -> Render url -> Html- --docsToExp :: Env -> HamletRules -> Scope -> [Doc] -> Q Exp--docsToExp env hr scope docs = do--    exps <- mapM (docToExp env hr scope) docs--    case exps of--        [] -> [|return ()|]--        [x] -> return x--        _ -> return $ DoE $ map NoBindS exps--- unIdent :: Ident -> String- unIdent (Ident s) = s- -@@ -159,169 +138,9 @@ recordToFieldNames conStr = do-   [fields] <- return [fields | RecC name fields <- cons, name == conName]-   return [fieldName | (fieldName, _, _) <- fields]- --docToExp :: Env -> HamletRules -> Scope -> Doc -> Q Exp--docToExp env hr scope (DocForall list idents inside) = do--    let list' = derefToExp scope list--    (pat, extraScope) <- bindingPattern idents--    let scope' = extraScope ++ scope--    mh <- [|F.mapM_|]--    inside' <- docsToExp env hr scope' inside--    let lam = LamE [pat] inside'--    return $ mh `AppE` lam `AppE` list'--docToExp env hr scope (DocWith [] inside) = do--    inside' <- docsToExp env hr scope inside--    return $ inside'--docToExp env hr scope (DocWith ((deref, idents):dis) inside) = do--    let deref' = derefToExp scope deref--    (pat, extraScope) <- bindingPattern idents--    let scope' = extraScope ++ scope--    inside' <- docToExp env hr scope' (DocWith dis inside)--    let lam = LamE [pat] inside'--    return $ lam `AppE` deref'--docToExp env hr scope (DocMaybe val idents inside mno) = do--    let val' = derefToExp scope val--    (pat, extraScope) <- bindingPattern idents--    let scope' = extraScope ++ scope--    inside' <- docsToExp env hr scope' inside--    let inside'' = LamE [pat] inside'--    ninside' <- case mno of--                    Nothing -> [|Nothing|]--                    Just no -> do--                        no' <- docsToExp env hr scope no--                        j <- [|Just|]--                        return $ j `AppE` no'--    mh <- [|maybeH|]--    return $ mh `AppE` val' `AppE` inside'' `AppE` ninside'--docToExp env hr scope (DocCond conds final) = do--    conds' <- mapM go conds--    final' <- case final of--                Nothing -> [|Nothing|]--                Just f -> do--                    f' <- docsToExp env hr scope f--                    j <- [|Just|]--                    return $ j `AppE` f'--    ch <- [|condH|]--    return $ ch `AppE` ListE conds' `AppE` final'--  where--    go :: (Deref, [Doc]) -> Q Exp--    go (d, docs) = do--        let d' = derefToExp scope d--        docs' <- docsToExp env hr scope docs--        return $ TupE [d', docs']--docToExp env hr scope (DocCase deref cases) = do--    let exp_ = derefToExp scope deref--    matches <- mapM toMatch cases--    return $ CaseE exp_ matches--  where--    readMay s =--        case reads s of--            (x, ""):_ -> Just x--            _ -> Nothing--    toMatch (idents, inside) = do--        let pat = case map unIdent idents of--                    ["_"] -> WildP--                    [str]--                        | Just i <- readMay str -> LitP $ IntegerL i--                    strs -> let (constr:fields) = map mkName strs--                            in ConP constr (map VarP fields)--        insideExp <- docsToExp env hr scope inside--        return $ Match pat (NormalB insideExp) []--docToExp env hr v (DocContent c) = contentToExp env hr v c----contentToExp :: Env -> HamletRules -> Scope -> Content -> Q Exp--contentToExp _ hr _ (ContentRaw s) = do--    os <- [|preEscapedText . pack|]--    let s' = LitE $ StringL s--    return $ hrFromHtml hr `AppE` (os `AppE` s')--contentToExp _ hr scope (ContentVar d) = do--    str <- [|toHtml|]--    return $ hrFromHtml hr `AppE` (str `AppE` derefToExp scope d)--contentToExp env hr scope (ContentUrl hasParams d) =--    case urlRender env of--        Nothing -> error "URL interpolation used, but no URL renderer provided"--        Just wrender -> wrender $ \render -> do--            let render' = return render--            ou <- if hasParams--                    then [|\(u, p) -> $(render') u p|]--                    else [|\u -> $(render') u []|]--            let d' = derefToExp scope d--            pet <- [|toHtml|]--            return $ hrFromHtml hr `AppE` (pet `AppE` (ou `AppE` d'))--contentToExp env hr scope (ContentEmbed d) = hrEmbed hr env $ derefToExp scope d--contentToExp env hr scope (ContentMsg d) =--    case msgRender env of--        Nothing -> error "Message interpolation used, but no message renderer provided"--        Just wrender -> wrender $ \render ->--            return $ hrFromHtml hr `AppE` (render `AppE` derefToExp scope d)--contentToExp _ hr scope (ContentAttrs d) = do--    html <- [|attrsToHtml . toAttributes|]--    return $ hrFromHtml hr `AppE` (html `AppE` derefToExp scope d)----shamlet :: QuasiQuoter--shamlet = hamletWithSettings htmlRules defaultHamletSettings----xshamlet :: QuasiQuoter--xshamlet = hamletWithSettings htmlRules xhtmlHamletSettings----htmlRules :: Q HamletRules--htmlRules = do--    i <- [|id|]--    return $ HamletRules i ($ (Env Nothing Nothing)) (\_ b -> return b)----hamlet :: QuasiQuoter--hamlet = hamletWithSettings hamletRules defaultHamletSettings----xhamlet :: QuasiQuoter--xhamlet = hamletWithSettings hamletRules xhtmlHamletSettings--- asHtmlUrl :: HtmlUrl url -> HtmlUrl url- asHtmlUrl = id- --hamletRules :: Q HamletRules--hamletRules = do--    i <- [|id|]--    let ur f = do--            r <- newName "_render"--            let env = Env--                    { urlRender = Just ($ (VarE r))--                    , msgRender = Nothing--                    }--            h <- f env--            return $ LamE [VarP r] h--    return $ HamletRules i ur em--  where--    em (Env (Just urender) Nothing) e = do--        asHtmlUrl' <- [|asHtmlUrl|]--        urender $ \ur' -> return ((asHtmlUrl' `AppE` e) `AppE` ur')--    em _ _ = error "bad Env"----ihamlet :: QuasiQuoter--ihamlet = hamletWithSettings ihamletRules defaultHamletSettings----ihamletRules :: Q HamletRules--ihamletRules = do--    i <- [|id|]--    let ur f = do--            u <- newName "_urender"--            m <- newName "_mrender"--            let env = Env--                    { urlRender = Just ($ (VarE u))--                    , msgRender = Just ($ (VarE m))--                    }--            h <- f env--            return $ LamE [VarP m, VarP u] h--    return $ HamletRules i ur em--  where--    em (Env (Just urender) (Just mrender)) e =--          urender $ \ur' -> mrender $ \mr -> return (e `AppE` mr `AppE` ur')--    em _ _ = error "bad Env"----hamletWithSettings :: Q HamletRules -> HamletSettings -> QuasiQuoter--hamletWithSettings hr set =--    QuasiQuoter--        { quoteExp = hamletFromString hr set--        }--- data HamletRules = HamletRules-     { hrFromHtml :: Exp-     , hrWithEnv :: (Env -> Q Exp) -> Q Exp-@@ -333,36 +152,6 @@ data Env = Env-     , msgRender :: Maybe ((Exp -> Q Exp) -> Q Exp)-     }- --hamletFromString :: Q HamletRules -> HamletSettings -> String -> Q Exp--hamletFromString qhr set s = do--    hr <- qhr--    case parseDoc set s of--        Error s' -> error s'--        Ok (_mnl, d) -> hrWithEnv hr $ \env -> docsToExp env hr [] d----hamletFileWithSettings :: Q HamletRules -> HamletSettings -> FilePath -> Q Exp--hamletFileWithSettings qhr set fp = do--#ifdef GHC_7_4--    qAddDependentFile fp--#endif--    contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp--    hamletFromString qhr set contents----hamletFile :: FilePath -> Q Exp--hamletFile = hamletFileWithSettings hamletRules defaultHamletSettings----xhamletFile :: FilePath -> Q Exp--xhamletFile = hamletFileWithSettings hamletRules xhtmlHamletSettings----shamletFile :: FilePath -> Q Exp--shamletFile = hamletFileWithSettings htmlRules defaultHamletSettings----xshamletFile :: FilePath -> Q Exp--xshamletFile = hamletFileWithSettings htmlRules xhtmlHamletSettings----ihamletFile :: FilePath -> Q Exp--ihamletFile = hamletFileWithSettings ihamletRules defaultHamletSettings--- varName :: Scope -> String -> Exp- varName _ "" = error "Illegal empty varName"- varName scope v@(_:_) = fromMaybe (strToExp v) $ lookup (Ident v) scope--- -1.7.10.4-
+ standalone/android/haskell-patches/hamlet-1.1.6.1_0001-remove-TH.patch view
@@ -0,0 +1,282 @@+From aa18210b7cc124e11fb71640d993de77492b63b1 Mon Sep 17 00:00:00 2001+From: Joey Hess <joey@kitenet.net>+Date: Mon, 15 Apr 2013 15:08:31 -0400+Subject: [PATCH] remove TH++Export functions referred to by TH splices, as these will be needed when+using the Evil Splicer+---+ Text/Hamlet.hs | 219 ++-------------------------------------------------------+ 1 file changed, 6 insertions(+), 213 deletions(-)++diff --git a/Text/Hamlet.hs b/Text/Hamlet.hs+index 4ac870a..63b8555 100644+--- a/Text/Hamlet.hs++++ b/Text/Hamlet.hs+@@ -11,35 +11,26 @@+ module Text.Hamlet+     ( -- * Plain HTML+       Html+-    , shamlet+-    , shamletFile+-    , xshamlet+-    , xshamletFile+       -- * Hamlet+     , HtmlUrl+-    , hamlet+-    , hamletFile+-    , xhamlet+-    , xhamletFile+       -- * I18N Hamlet+     , HtmlUrlI18n+-    , ihamlet+-    , ihamletFile+       -- * Type classes+     , ToAttributes (..)+       -- * Internal, for making more+     , HamletSettings (..)+     , NewlineStyle (..)+-    , hamletWithSettings+-    , hamletFileWithSettings+     , defaultHamletSettings+     , xhtmlHamletSettings+     , Env (..)+     , HamletRules (..)+-    , hamletRules+-    , ihamletRules+-    , htmlRules+     , CloseStyle (..)++    , condH++    , maybeH++++    -- referred to in TH splices++    , attrsToHtml++    , asHtmlUrl+     ) where+ + import Text.Shakespeare.Base+@@ -90,14 +81,6 @@ type HtmlUrl url = Render url -> Html+ -- | A function generating an 'Html' given a message translator and a URL rendering function.+ type HtmlUrlI18n msg url = Translate msg -> Render url -> Html+ +-docsToExp :: Env -> HamletRules -> Scope -> [Doc] -> Q Exp+-docsToExp env hr scope docs = do+-    exps <- mapM (docToExp env hr scope) docs+-    case exps of+-        [] -> [|return ()|]+-        [x] -> return x+-        _ -> return $ DoE $ map NoBindS exps+-+ unIdent :: Ident -> String+ unIdent (Ident s) = s+ +@@ -159,169 +142,9 @@ recordToFieldNames conStr = do+   [fields] <- return [fields | RecC name fields <- cons, name == conName]+   return [fieldName | (fieldName, _, _) <- fields]+ +-docToExp :: Env -> HamletRules -> Scope -> Doc -> Q Exp+-docToExp env hr scope (DocForall list idents inside) = do+-    let list' = derefToExp scope list+-    (pat, extraScope) <- bindingPattern idents+-    let scope' = extraScope ++ scope+-    mh <- [|F.mapM_|]+-    inside' <- docsToExp env hr scope' inside+-    let lam = LamE [pat] inside'+-    return $ mh `AppE` lam `AppE` list'+-docToExp env hr scope (DocWith [] inside) = do+-    inside' <- docsToExp env hr scope inside+-    return $ inside'+-docToExp env hr scope (DocWith ((deref, idents):dis) inside) = do+-    let deref' = derefToExp scope deref+-    (pat, extraScope) <- bindingPattern idents+-    let scope' = extraScope ++ scope+-    inside' <- docToExp env hr scope' (DocWith dis inside)+-    let lam = LamE [pat] inside'+-    return $ lam `AppE` deref'+-docToExp env hr scope (DocMaybe val idents inside mno) = do+-    let val' = derefToExp scope val+-    (pat, extraScope) <- bindingPattern idents+-    let scope' = extraScope ++ scope+-    inside' <- docsToExp env hr scope' inside+-    let inside'' = LamE [pat] inside'+-    ninside' <- case mno of+-                    Nothing -> [|Nothing|]+-                    Just no -> do+-                        no' <- docsToExp env hr scope no+-                        j <- [|Just|]+-                        return $ j `AppE` no'+-    mh <- [|maybeH|]+-    return $ mh `AppE` val' `AppE` inside'' `AppE` ninside'+-docToExp env hr scope (DocCond conds final) = do+-    conds' <- mapM go conds+-    final' <- case final of+-                Nothing -> [|Nothing|]+-                Just f -> do+-                    f' <- docsToExp env hr scope f+-                    j <- [|Just|]+-                    return $ j `AppE` f'+-    ch <- [|condH|]+-    return $ ch `AppE` ListE conds' `AppE` final'+-  where+-    go :: (Deref, [Doc]) -> Q Exp+-    go (d, docs) = do+-        let d' = derefToExp scope d+-        docs' <- docsToExp env hr scope docs+-        return $ TupE [d', docs']+-docToExp env hr scope (DocCase deref cases) = do+-    let exp_ = derefToExp scope deref+-    matches <- mapM toMatch cases+-    return $ CaseE exp_ matches+-  where+-    readMay s =+-        case reads s of+-            (x, ""):_ -> Just x+-            _ -> Nothing+-    toMatch (idents, inside) = do+-        let pat = case map unIdent idents of+-                    ["_"] -> WildP+-                    [str]+-                        | Just i <- readMay str -> LitP $ IntegerL i+-                    strs -> let (constr:fields) = map mkName strs+-                            in ConP constr (map VarP fields)+-        insideExp <- docsToExp env hr scope inside+-        return $ Match pat (NormalB insideExp) []+-docToExp env hr v (DocContent c) = contentToExp env hr v c+-+-contentToExp :: Env -> HamletRules -> Scope -> Content -> Q Exp+-contentToExp _ hr _ (ContentRaw s) = do+-    os <- [|preEscapedText . pack|]+-    let s' = LitE $ StringL s+-    return $ hrFromHtml hr `AppE` (os `AppE` s')+-contentToExp _ hr scope (ContentVar d) = do+-    str <- [|toHtml|]+-    return $ hrFromHtml hr `AppE` (str `AppE` derefToExp scope d)+-contentToExp env hr scope (ContentUrl hasParams d) =+-    case urlRender env of+-        Nothing -> error "URL interpolation used, but no URL renderer provided"+-        Just wrender -> wrender $ \render -> do+-            let render' = return render+-            ou <- if hasParams+-                    then [|\(u, p) -> $(render') u p|]+-                    else [|\u -> $(render') u []|]+-            let d' = derefToExp scope d+-            pet <- [|toHtml|]+-            return $ hrFromHtml hr `AppE` (pet `AppE` (ou `AppE` d'))+-contentToExp env hr scope (ContentEmbed d) = hrEmbed hr env $ derefToExp scope d+-contentToExp env hr scope (ContentMsg d) =+-    case msgRender env of+-        Nothing -> error "Message interpolation used, but no message renderer provided"+-        Just wrender -> wrender $ \render ->+-            return $ hrFromHtml hr `AppE` (render `AppE` derefToExp scope d)+-contentToExp _ hr scope (ContentAttrs d) = do+-    html <- [|attrsToHtml . toAttributes|]+-    return $ hrFromHtml hr `AppE` (html `AppE` derefToExp scope d)+-+-shamlet :: QuasiQuoter+-shamlet = hamletWithSettings htmlRules defaultHamletSettings+-+-xshamlet :: QuasiQuoter+-xshamlet = hamletWithSettings htmlRules xhtmlHamletSettings+-+-htmlRules :: Q HamletRules+-htmlRules = do+-    i <- [|id|]+-    return $ HamletRules i ($ (Env Nothing Nothing)) (\_ b -> return b)+-+-hamlet :: QuasiQuoter+-hamlet = hamletWithSettings hamletRules defaultHamletSettings+-+-xhamlet :: QuasiQuoter+-xhamlet = hamletWithSettings hamletRules xhtmlHamletSettings+-+ asHtmlUrl :: HtmlUrl url -> HtmlUrl url+ asHtmlUrl = id+ +-hamletRules :: Q HamletRules+-hamletRules = do+-    i <- [|id|]+-    let ur f = do+-            r <- newName "_render"+-            let env = Env+-                    { urlRender = Just ($ (VarE r))+-                    , msgRender = Nothing+-                    }+-            h <- f env+-            return $ LamE [VarP r] h+-    return $ HamletRules i ur em+-  where+-    em (Env (Just urender) Nothing) e = do+-        asHtmlUrl' <- [|asHtmlUrl|]+-        urender $ \ur' -> return ((asHtmlUrl' `AppE` e) `AppE` ur')+-    em _ _ = error "bad Env"+-+-ihamlet :: QuasiQuoter+-ihamlet = hamletWithSettings ihamletRules defaultHamletSettings+-+-ihamletRules :: Q HamletRules+-ihamletRules = do+-    i <- [|id|]+-    let ur f = do+-            u <- newName "_urender"+-            m <- newName "_mrender"+-            let env = Env+-                    { urlRender = Just ($ (VarE u))+-                    , msgRender = Just ($ (VarE m))+-                    }+-            h <- f env+-            return $ LamE [VarP m, VarP u] h+-    return $ HamletRules i ur em+-  where+-    em (Env (Just urender) (Just mrender)) e =+-          urender $ \ur' -> mrender $ \mr -> return (e `AppE` mr `AppE` ur')+-    em _ _ = error "bad Env"+-+-hamletWithSettings :: Q HamletRules -> HamletSettings -> QuasiQuoter+-hamletWithSettings hr set =+-    QuasiQuoter+-        { quoteExp = hamletFromString hr set+-        }+-+ data HamletRules = HamletRules+     { hrFromHtml :: Exp+     , hrWithEnv :: (Env -> Q Exp) -> Q Exp+@@ -333,36 +156,6 @@ data Env = Env+     , msgRender :: Maybe ((Exp -> Q Exp) -> Q Exp)+     }+ +-hamletFromString :: Q HamletRules -> HamletSettings -> String -> Q Exp+-hamletFromString qhr set s = do+-    hr <- qhr+-    case parseDoc set s of+-        Error s' -> error s'+-        Ok (_mnl, d) -> hrWithEnv hr $ \env -> docsToExp env hr [] d+-+-hamletFileWithSettings :: Q HamletRules -> HamletSettings -> FilePath -> Q Exp+-hamletFileWithSettings qhr set fp = do+-#ifdef GHC_7_4+-    qAddDependentFile fp+-#endif+-    contents <- fmap TL.unpack $ qRunIO $ readUtf8File fp+-    hamletFromString qhr set contents+-+-hamletFile :: FilePath -> Q Exp+-hamletFile = hamletFileWithSettings hamletRules defaultHamletSettings+-+-xhamletFile :: FilePath -> Q Exp+-xhamletFile = hamletFileWithSettings hamletRules xhtmlHamletSettings+-+-shamletFile :: FilePath -> Q Exp+-shamletFile = hamletFileWithSettings htmlRules defaultHamletSettings+-+-xshamletFile :: FilePath -> Q Exp+-xshamletFile = hamletFileWithSettings htmlRules xhtmlHamletSettings+-+-ihamletFile :: FilePath -> Q Exp+-ihamletFile = hamletFileWithSettings ihamletRules defaultHamletSettings+-+ varName :: Scope -> String -> Exp+ varName _ "" = error "Illegal empty varName"+ varName scope v@(_:_) = fromMaybe (strToExp v) $ lookup (Ident v) scope+-- +1.8.2.rc3+
+ standalone/android/haskell-patches/wai-app-static-1.3.1-remove-TH.patch view
@@ -0,0 +1,36 @@+From c18ae75852b1340ca502528138bf421659f61a3d Mon Sep 17 00:00:00 2001+From: Joey Hess <joey@kitenet.net>+Date: Mon, 15 Apr 2013 12:44:15 -0400+Subject: [PATCH] remove TH++Should not need these icons in git-annex, so not worth using the Evil+Splicer.+---+ Network/Wai/Application/Static.hs | 4 ----+ 1 file changed, 4 deletions(-)++diff --git a/Network/Wai/Application/Static.hs b/Network/Wai/Application/Static.hs+index 3195fbb..b48aa01 100644+--- a/Network/Wai/Application/Static.hs++++ b/Network/Wai/Application/Static.hs+@@ -33,8 +33,6 @@ import Control.Monad.IO.Class (liftIO)+ + import Blaze.ByteString.Builder (toByteString)+ +-import Data.FileEmbed (embedFile)+-+ import Data.Text (Text)+ import qualified Data.Text as T+ +@@ -198,8 +196,6 @@ staticAppPieces _ _ req+         H.status405+         [("Content-Type", "text/plain")]+         "Only GET is supported"+-staticAppPieces _ [".hidden", "folder.png"] _  = return $ W.responseLBS H.status200 [("Content-Type", "image/png")] $ L.fromChunks [$(embedFile "images/folder.png")]+-staticAppPieces _ [".hidden", "haskell.png"] _ = return $ W.responseLBS H.status200 [("Content-Type", "image/png")] $ L.fromChunks [$(embedFile "images/haskell.png")]+ staticAppPieces ss rawPieces req = liftIO $ do+     case toPieces rawPieces of+         Just pieces -> checkPieces ss pieces req >>= response+-- +1.8.2.rc3+
+ standalone/android/haskell-patches/yesod-form-1.2.1.1-0002-expand-TH.patch view
@@ -0,0 +1,1606 @@+From f98c22ec71695537e0e008a0bd54affdf8a60f64 Mon Sep 17 00:00:00 2001+From: Joey Hess <joey@kitenet.net>+Date: Mon, 15 Apr 2013 17:35:57 -0400+Subject: [PATCH 2/2] expand TH++Used the EvilSplicer, and then some manual fixups, as it is apparently+buggy. Also a few module import fixes.+---+ Yesod/Form/Fields.hs    | 623 ++++++++++++++++++++++++++++++++++++++----------+ Yesod/Form/Functions.hs | 240 +++++++++++++++----+ Yesod/Form/Jquery.hs    | 141 ++++++++---+ Yesod/Form/MassInput.hs | 228 ++++++++++++++----+ Yesod/Form/Nic.hs       |  59 ++++-+ 5 files changed, 1042 insertions(+), 249 deletions(-)++diff --git a/Yesod/Form/Fields.hs b/Yesod/Form/Fields.hs+index 7917ce2..db76ea2 100644+--- a/Yesod/Form/Fields.hs++++ b/Yesod/Form/Fields.hs+@@ -46,11 +46,22 @@ module Yesod.Form.Fields+     , optionsEnum+     ) where+ ++import qualified Data.Text.Lazy.Builder++import qualified Text.Shakespeare++import qualified Data.Monoid++import qualified Text.Julius++import qualified "blaze-markup" Text.Blaze.Internal++import qualified "blaze-markup" Text.Blaze as Text.Blaze.Internal++import qualified "blaze-html" Text.Blaze.Html++import qualified Yesod.Widget++import qualified Text.Css++import qualified Control.Monad++import qualified Data.Foldable+ import Yesod.Form.Types+ import Yesod.Form.I18n.English+ import Yesod.Form.Functions (parseHelper)+ import Yesod.Handler (getMessageRender)+-import Yesod.Widget (toWidget, whamlet, GWidget)++import Yesod.Widget (toWidget, GWidget)+ import Yesod.Message (RenderMessage (renderMessage), SomeMessage (..))+ import Text.Hamlet+ import Text.Blaze (ToMarkup (toMarkup), preEscapedToMarkup, unsafeByteString)+@@ -108,10 +119,24 @@ intField = Field+             Right (a, "") -> Right a+             _ -> Left $ MsgInvalidInteger s+ +-    , fieldView = \theId name attrs val isReq -> toWidget [hamlet|+-$newline never+-<input id="#{theId}" name="#{name}" *{attrs} type="number" :isReq:required="" value="#{showVal val}">+-|]++    , fieldView = \theId name attrs val isReq -> toWidget  $     \ _render_amMY++      -> do { id++                ((Text.Blaze.Internal.preEscapedText . pack) "<input id=\"");++              id (Text.Blaze.Html.toHtml theId);++              id ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\"");++              id (Text.Blaze.Html.toHtml name);++              id++                ((Text.Blaze.Internal.preEscapedText . pack) "\" type=\"number\"");++              Text.Hamlet.condH++                [(isReq, ++                  id ((Text.Blaze.Internal.preEscapedText . pack) " required=\"\""))]++                Nothing;++              id ((Text.Blaze.Internal.preEscapedText . pack) " value=\"");++              id (Text.Blaze.Html.toHtml (showVal val));++              id ((Text.Blaze.Internal.preEscapedText . pack) "\"");++              id ((Text.Hamlet.attrsToHtml . toAttributes) attrs);++              id ((Text.Blaze.Internal.preEscapedText . pack) ">") }+++     , fieldEnctype = UrlEncoded+     }+   where+@@ -125,10 +150,24 @@ doubleField = Field+             Right (a, "") -> Right a+             _ -> Left $ MsgInvalidNumber s+ +-    , fieldView = \theId name attrs val isReq -> toWidget [hamlet|+-$newline never+-<input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required="" value="#{showVal val}">+-|]++    , fieldView = \theId name attrs val isReq -> toWidget  $     \ _render_amNa++      -> do { id++                ((Text.Blaze.Internal.preEscapedText . pack) "<input id=\"");++              id (Text.Blaze.Html.toHtml theId);++              id ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\"");++              id (Text.Blaze.Html.toHtml name);++              id++                ((Text.Blaze.Internal.preEscapedText . pack) "\" type=\"text\"");++              Text.Hamlet.condH++                [(isReq, ++                  id ((Text.Blaze.Internal.preEscapedText . pack) " required=\"\""))]++                Nothing;++              id ((Text.Blaze.Internal.preEscapedText . pack) " value=\"");++              id (Text.Blaze.Html.toHtml (showVal val));++              id ((Text.Blaze.Internal.preEscapedText . pack) "\"");++              id ((Text.Hamlet.attrsToHtml . toAttributes) attrs);++              id ((Text.Blaze.Internal.preEscapedText . pack) ">") }+++     , fieldEnctype = UrlEncoded+     }+   where showVal = either id (pack . show)+@@ -136,10 +175,24 @@ $newline never+ dayField :: RenderMessage master FormMessage => Field sub master Day+ dayField = Field+     { fieldParse = parseHelper $ parseDate . unpack+-    , fieldView = \theId name attrs val isReq -> toWidget [hamlet|+-$newline never+-<input id="#{theId}" name="#{name}" *{attrs} type="date" :isReq:required="" value="#{showVal val}">+-|]++    , fieldView = \theId name attrs val isReq -> toWidget  $     \ _render_amNk++      -> do { id++                ((Text.Blaze.Internal.preEscapedText . pack) "<input id=\"");++              id (Text.Blaze.Html.toHtml theId);++              id ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\"");++              id (Text.Blaze.Html.toHtml name);++              id++                ((Text.Blaze.Internal.preEscapedText . pack) "\" type=\"date\"");++              Text.Hamlet.condH++                [(isReq, ++                  id ((Text.Blaze.Internal.preEscapedText . pack) " required=\"\""))]++                Nothing;++              id ((Text.Blaze.Internal.preEscapedText . pack) " value=\"");++              id (Text.Blaze.Html.toHtml (showVal val));++              id ((Text.Blaze.Internal.preEscapedText . pack) "\"");++              id ((Text.Hamlet.attrsToHtml . toAttributes) attrs);++              id ((Text.Blaze.Internal.preEscapedText . pack) ">") }+++     , fieldEnctype = UrlEncoded+     }+   where showVal = either id (pack . show)+@@ -147,10 +200,23 @@ $newline never+ timeField :: RenderMessage master FormMessage => Field sub master TimeOfDay+ timeField = Field+     { fieldParse = parseHelper parseTime+-    , fieldView = \theId name attrs val isReq -> toWidget [hamlet|+-$newline never+-<input id="#{theId}" name="#{name}" *{attrs} :isReq:required="" value="#{showVal val}">+-|]++    , fieldView = \theId name attrs val isReq -> toWidget  $     \ _render_amNx++      -> do { id++                ((Text.Blaze.Internal.preEscapedText . pack) "<input id=\"");++              id (Text.Blaze.Html.toHtml theId);++              id ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\"");++              id (Text.Blaze.Html.toHtml name);++              id ((Text.Blaze.Internal.preEscapedText . pack) "\"");++              Text.Hamlet.condH++                [(isReq, ++                  id ((Text.Blaze.Internal.preEscapedText . pack) " required=\"\""))]++                Nothing;++              id ((Text.Blaze.Internal.preEscapedText . pack) " value=\"");++              id (Text.Blaze.Html.toHtml (showVal val));++              id ((Text.Blaze.Internal.preEscapedText . pack) "\"");++              id ((Text.Hamlet.attrsToHtml . toAttributes) attrs);++              id ((Text.Blaze.Internal.preEscapedText . pack) ">") }+++     , fieldEnctype = UrlEncoded+     }+   where+@@ -163,10 +229,18 @@ $newline never+ htmlField :: RenderMessage master FormMessage => Field sub master Html+ htmlField = Field+     { fieldParse = parseHelper $ Right . preEscapedText . sanitizeBalance+-    , fieldView = \theId name attrs val _isReq -> toWidget [hamlet|+-$newline never+-<textarea id="#{theId}" name="#{name}" *{attrs}>#{showVal val}+-|]++    , fieldView = \theId name attrs val _isReq -> toWidget  $     \ _render_amNH++      -> do { id++                ((Text.Blaze.Internal.preEscapedText . pack) "<textarea id=\"");++              id (Text.Blaze.Html.toHtml theId);++              id ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\"");++              id (Text.Blaze.Html.toHtml name);++              id ((Text.Blaze.Internal.preEscapedText . pack) "\"");++              id ((Text.Hamlet.attrsToHtml . toAttributes) attrs);++              id ((Text.Blaze.Internal.preEscapedText . pack) ">");++              id (Text.Blaze.Html.toHtml (showVal val));++              id ((Text.Blaze.Internal.preEscapedText . pack) "</textarea>") }+++     , fieldEnctype = UrlEncoded+     }+   where showVal = either id (pack . renderHtml)+@@ -192,10 +266,18 @@ instance ToHtml Textarea where+ textareaField :: RenderMessage master FormMessage => Field sub master Textarea+ textareaField = Field+     { fieldParse = parseHelper $ Right . Textarea+-    , fieldView = \theId name attrs val _isReq -> toWidget [hamlet|+-$newline never+-<textarea id="#{theId}" name="#{name}" *{attrs}>#{either id unTextarea val}+-|]++    , fieldView = \theId name attrs val _isReq -> toWidget  $     \ _render_amNQ++      -> do { id++                ((Text.Blaze.Internal.preEscapedText . pack) "<textarea id=\"");++              id (Text.Blaze.Html.toHtml theId);++              id ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\"");++              id (Text.Blaze.Html.toHtml name);++              id ((Text.Blaze.Internal.preEscapedText . pack) "\"");++              id ((Text.Hamlet.attrsToHtml . toAttributes) attrs);++              id ((Text.Blaze.Internal.preEscapedText . pack) ">");++              id (Text.Blaze.Html.toHtml (either id unTextarea val));++              id ((Text.Blaze.Internal.preEscapedText . pack) "</textarea>") }+++     , fieldEnctype = UrlEncoded+     }+ +@@ -203,10 +285,19 @@ hiddenField :: (PathPiece p, RenderMessage master FormMessage)+             => Field sub master p+ hiddenField = Field+     { fieldParse = parseHelper $ maybe (Left MsgValueRequired) Right . fromPathPiece+-    , fieldView = \theId name attrs val _isReq -> toWidget [hamlet|+-$newline never+-<input type="hidden" id="#{theId}" name="#{name}" *{attrs} value="#{either id toPathPiece val}">+-|]++    , fieldView = \theId name attrs val _isReq -> toWidget  $     \ _render_amNZ++      -> do { id++                ((Text.Blaze.Internal.preEscapedText . pack)++                   "<input type=\"hidden\" id=\"");++              id (Text.Blaze.Html.toHtml theId);++              id ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\"");++              id (Text.Blaze.Html.toHtml name);++              id ((Text.Blaze.Internal.preEscapedText . pack) "\" value=\"");++              id (Text.Blaze.Html.toHtml (either id toPathPiece val));++              id ((Text.Blaze.Internal.preEscapedText . pack) "\"");++              id ((Text.Hamlet.attrsToHtml . toAttributes) attrs);++              id ((Text.Blaze.Internal.preEscapedText . pack) ">") }+++     , fieldEnctype = UrlEncoded+     }+ +@@ -214,20 +305,50 @@ textField :: RenderMessage master FormMessage => Field sub master Text+ textField = Field+     { fieldParse = parseHelper $ Right+     , fieldView = \theId name attrs val isReq ->+-        [whamlet|+-$newline never+-<input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required value="#{either id id val}">+-|]++        do { toWidget++               ((Text.Blaze.Internal.preEscapedText . pack) "<input id=\"");++             toWidget (Text.Blaze.Html.toHtml theId);++             toWidget++               ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\"");++             toWidget (Text.Blaze.Html.toHtml name);++             toWidget++               ((Text.Blaze.Internal.preEscapedText . pack) "\" type=\"text\"");++             Text.Hamlet.condH++               [(isReq, ++                 toWidget++                   ((Text.Blaze.Internal.preEscapedText . pack) " required"))]++               Nothing;++             toWidget ((Text.Blaze.Internal.preEscapedText . pack) " value=\"");++             toWidget (Text.Blaze.Html.toHtml (either id id val));++             toWidget ((Text.Blaze.Internal.preEscapedText . pack) "\"");++             toWidget ((Text.Hamlet.attrsToHtml . toAttributes) attrs);++             toWidget ((Text.Blaze.Internal.preEscapedText . pack) ">") }+++     , fieldEnctype = UrlEncoded+     }+ + passwordField :: RenderMessage master FormMessage => Field sub master Text+ passwordField = Field+     { fieldParse = parseHelper $ Right+-    , fieldView = \theId name attrs val isReq -> toWidget [hamlet|+-$newline never+-<input id="#{theId}" name="#{name}" *{attrs} type="password" :isReq:required="" value="#{either id id val}">+-|]++    , fieldView = \theId name attrs val isReq -> toWidget  $     \ _render_amOg++      -> do { id++                ((Text.Blaze.Internal.preEscapedText . pack) "<input id=\"");++              id (Text.Blaze.Html.toHtml theId);++              id ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\"");++              id (Text.Blaze.Html.toHtml name);++              id++                ((Text.Blaze.Internal.preEscapedText . pack)++                   "\" type=\"password\"");++              Text.Hamlet.condH++                [(isReq, ++                  id ((Text.Blaze.Internal.preEscapedText . pack) " required=\"\""))]++                Nothing;++              id ((Text.Blaze.Internal.preEscapedText . pack) " value=\"");++              id (Text.Blaze.Html.toHtml (either id id val));++              id ((Text.Blaze.Internal.preEscapedText . pack) "\"");++              id ((Text.Hamlet.attrsToHtml . toAttributes) attrs);++              id ((Text.Blaze.Internal.preEscapedText . pack) ">") }+++     , fieldEnctype = UrlEncoded+     }+ +@@ -305,10 +426,24 @@ emailField = Field+                 then Right s+                 else Left $ MsgInvalidEmail s+ #endif+-    , fieldView = \theId name attrs val isReq -> toWidget [hamlet|+-$newline never+-<input id="#{theId}" name="#{name}" *{attrs} type="email" :isReq:required="" value="#{either id id val}">+-|]++    , fieldView = \theId name attrs val isReq -> toWidget  $     \ _render_amOO++      -> do { id++                ((Text.Blaze.Internal.preEscapedText . pack) "<input id=\"");++              id (Text.Blaze.Html.toHtml theId);++              id ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\"");++              id (Text.Blaze.Html.toHtml name);++              id++                ((Text.Blaze.Internal.preEscapedText . pack) "\" type=\"email\"");++              Text.Hamlet.condH++                [(isReq, ++                  id ((Text.Blaze.Internal.preEscapedText . pack) " required=\"\""))]++                Nothing;++              id ((Text.Blaze.Internal.preEscapedText . pack) " value=\"");++              id (Text.Blaze.Html.toHtml (either id id val));++              id ((Text.Blaze.Internal.preEscapedText . pack) "\"");++              id ((Text.Hamlet.attrsToHtml . toAttributes) attrs);++              id ((Text.Blaze.Internal.preEscapedText . pack) ">") }+++     , fieldEnctype = UrlEncoded+     }+ +@@ -317,20 +452,60 @@ searchField :: RenderMessage master FormMessage => AutoFocus -> Field sub master+ searchField autoFocus = Field+     { fieldParse = parseHelper Right+     , fieldView = \theId name attrs val isReq -> do+-        [whamlet|\+-$newline never+-<input id="#{theId}" name="#{name}" *{attrs} type="search" :isReq:required="" :autoFocus:autofocus="" value="#{either id id val}">+-|]++        do { toWidget++               ((Text.Blaze.Internal.preEscapedText . pack) "<input id=\"");++             toWidget (Text.Blaze.Html.toHtml theId);++             toWidget++               ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\"");++             toWidget (Text.Blaze.Html.toHtml name);++             toWidget++               ((Text.Blaze.Internal.preEscapedText . pack) "\" type=\"search\"");++             Text.Hamlet.condH++               [(isReq, ++                 toWidget++                   ((Text.Blaze.Internal.preEscapedText . pack) " required=\"\""))]++               Nothing;++             Text.Hamlet.condH++               [(autoFocus, ++                 toWidget++                   ((Text.Blaze.Internal.preEscapedText . pack) " autofocus=\"\""))]++               Nothing;++             toWidget ((Text.Blaze.Internal.preEscapedText . pack) " value=\"");++             toWidget (Text.Blaze.Html.toHtml (either id id val));++             toWidget ((Text.Blaze.Internal.preEscapedText . pack) "\"");++             toWidget ((Text.Hamlet.attrsToHtml . toAttributes) attrs);++             toWidget ((Text.Blaze.Internal.preEscapedText . pack) ">") }+++         when autoFocus $ do+           -- we want this javascript to be placed immediately after the field+-          [whamlet|+-$newline never+-<script>if (!('autofocus' in document.createElement('input'))) {document.getElementById('#{theId}').focus();}+-|]+-          toWidget [cassius|+-            #{theId}+-              -webkit-appearance: textfield+-            |]++          do { toWidget++                 ((Text.Blaze.Internal.preEscapedText . pack)++                    "<script>if (!('autofocus' in document.createElement('input'))) {document.getElementById('");++               toWidget (Text.Blaze.Html.toHtml theId);++               toWidget++                 ((Text.Blaze.Internal.preEscapedText . pack)++                    "').focus();}</script>") }++++          toWidget  $           \ _render_amP5++            -> (Text.Css.CssNoWhitespace++                . (foldr ($) []))++                 [((++)++                   $ (map++                        Text.Css.Css++                        ((((:)++                             (Text.Css.Css'++                                (Data.Monoid.mconcat [toCss theId])++                                [(Data.Monoid.mconcat++                                    [(Text.Css.fromText++                                      . Text.Css.pack)++                                       "-webkit-appearance"], ++                                  Data.Monoid.mconcat++                                    [(Text.Css.fromText++                                      . Text.Css.pack)++                                       "textfield"])]))++                          . (foldr (.) id []))++                           [])))]+++     , fieldEnctype = UrlEncoded+     }+ +@@ -341,10 +516,25 @@ urlField = Field+             Nothing -> Left $ MsgInvalidUrl s+             Just _ -> Right s+     , fieldView = \theId name attrs val isReq ->+-        [whamlet|+-$newline never+-<input ##{theId} name=#{name} *{attrs} type=url :isReq:required value=#{either id id val}>+-|]++        do { toWidget++               ((Text.Blaze.Internal.preEscapedText . pack) "<input id=\"");++             toWidget (Text.Blaze.Html.toHtml theId);++             toWidget++               ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\"");++             toWidget (Text.Blaze.Html.toHtml name);++             toWidget++               ((Text.Blaze.Internal.preEscapedText . pack) "\" type=\"url\"");++             Text.Hamlet.condH++               [(isReq, ++                 toWidget++                   ((Text.Blaze.Internal.preEscapedText . pack) " required"))]++               Nothing;++             toWidget ((Text.Blaze.Internal.preEscapedText . pack) " value=\"");++             toWidget (Text.Blaze.Html.toHtml (either id id val));++             toWidget ((Text.Blaze.Internal.preEscapedText . pack) "\"");++             toWidget ((Text.Hamlet.attrsToHtml . toAttributes) attrs);++             toWidget ((Text.Blaze.Internal.preEscapedText . pack) ">") }+++     , fieldEnctype = UrlEncoded+     }+ +@@ -353,18 +543,48 @@ selectFieldList = selectField . optionsPairs+ + selectField :: (Eq a, RenderMessage master FormMessage) => GHandler sub master (OptionList a) -> Field sub master a+ selectField = selectFieldHelper+-    (\theId name attrs inside -> [whamlet|+-$newline never+-<select ##{theId} name=#{name} *{attrs}>^{inside}+-|]) -- outside+-    (\_theId _name isSel -> [whamlet|+-$newline never+-<option value=none :isSel:selected>_{MsgSelectNone}+-|]) -- onOpt+-    (\_theId _name _attrs value isSel text -> [whamlet|+-$newline never+-<option value=#{value} :isSel:selected>#{text}+-|]) -- inside++    (\theId name attrs inside ->     do { toWidget++           ((Text.Blaze.Internal.preEscapedText . pack) "<select id=\"");++         toWidget (Text.Blaze.Html.toHtml theId);++         toWidget++           ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\"");++         toWidget (Text.Blaze.Html.toHtml name);++         toWidget ((Text.Blaze.Internal.preEscapedText . pack) "\"");++         toWidget ((Text.Hamlet.attrsToHtml . toAttributes) attrs);++         toWidget ((Text.Blaze.Internal.preEscapedText . pack) ">");++         toWidget inside;++         toWidget++           ((Text.Blaze.Internal.preEscapedText . pack) "</select>") })++ -- outside++    (\_theId _name isSel ->     do { toWidget++           ((Text.Blaze.Internal.preEscapedText . pack)++              "<option value=\"none\"");++         Text.Hamlet.condH++           [(isSel, ++             toWidget++               ((Text.Blaze.Internal.preEscapedText . pack) " selected"))]++           Nothing;++         toWidget ((Text.Blaze.Internal.preEscapedText . pack) ">");++         (((Control.Monad.liftM (Text.Blaze.Html.toHtml .))++           $ (Yesod.Widget.liftW getMessageRender))++          >>= (\ urender_amPs -> toWidget (urender_amPs MsgSelectNone)));++         toWidget++           ((Text.Blaze.Internal.preEscapedText . pack) "</option>") })++ -- onOpt++    (\_theId _name _attrs value isSel text ->     do { toWidget++           ((Text.Blaze.Internal.preEscapedText . pack) "<option value=\"");++         toWidget (Text.Blaze.Html.toHtml value);++         toWidget ((Text.Blaze.Internal.preEscapedText . pack) "\"");++         Text.Hamlet.condH++           [(isSel, ++             toWidget++               ((Text.Blaze.Internal.preEscapedText . pack) " selected"))]++           Nothing;++         toWidget ((Text.Blaze.Internal.preEscapedText . pack) ">");++         toWidget (Text.Blaze.Html.toHtml text);++         toWidget++           ((Text.Blaze.Internal.preEscapedText . pack) "</option>") })++ -- inside+ + multiSelectFieldList :: (Eq a, RenderMessage master FormMessage, RenderMessage master msg) => [(msg, a)] -> Field sub master [a]+ multiSelectFieldList = multiSelectField . optionsPairs+@@ -385,12 +605,40 @@ multiSelectField ioptlist =+     view theId name attrs val isReq = do+         opts <- fmap olOptions $ lift ioptlist+         let selOpts = map (id &&& (optselected val)) opts+-        [whamlet|+-$newline never+-            <select ##{theId} name=#{name} :isReq:required multiple *{attrs}>+-                $forall (opt, optsel) <- selOpts+-                    <option value=#{optionExternalValue opt} :optsel:selected>#{optionDisplay opt}+-                |]++        do { toWidget++               ((Text.Blaze.Internal.preEscapedText . pack) "<select id=\"");++             toWidget (Text.Blaze.Html.toHtml theId);++             toWidget++               ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\"");++             toWidget (Text.Blaze.Html.toHtml name);++             toWidget ((Text.Blaze.Internal.preEscapedText . pack) "\"");++             Text.Hamlet.condH++               [(isReq, ++                 toWidget++                   ((Text.Blaze.Internal.preEscapedText . pack) " required"))]++               Nothing;++             toWidget ((Text.Blaze.Internal.preEscapedText . pack) " multiple");++             toWidget ((Text.Hamlet.attrsToHtml . toAttributes) attrs);++             toWidget ((Text.Blaze.Internal.preEscapedText . pack) ">");++             Data.Foldable.mapM_++               (\ (opt_amPV, optsel_amPW)++                  -> do { toWidget++                            ((Text.Blaze.Internal.preEscapedText . pack) "<option value=\"");++                          toWidget (Text.Blaze.Html.toHtml (optionExternalValue opt_amPV));++                          toWidget ((Text.Blaze.Internal.preEscapedText . pack) "\"");++                          Text.Hamlet.condH++                            [(optsel_amPW, ++                              toWidget++                                ((Text.Blaze.Internal.preEscapedText . pack) " selected"))]++                            Nothing;++                          toWidget ((Text.Blaze.Internal.preEscapedText . pack) ">");++                          toWidget (Text.Blaze.Html.toHtml (optionDisplay opt_amPV));++                          toWidget++                            ((Text.Blaze.Internal.preEscapedText . pack) "</option>") })++               selOpts;++             toWidget++               ((Text.Blaze.Internal.preEscapedText . pack) "</select>") }+++         where+             optselected (Left _) _ = False+             optselected (Right vals) opt = (optionInternalValue opt) `elem` vals+@@ -400,41 +648,140 @@ radioFieldList = radioField . optionsPairs+ + radioField :: (Eq a, RenderMessage master FormMessage) => GHandler sub master (OptionList a) -> Field sub master a+ radioField = selectFieldHelper+-    (\theId _name _attrs inside -> [whamlet|+-$newline never+-<div ##{theId}>^{inside}+-|])+-    (\theId name isSel -> [whamlet|+-$newline never+-<label .radio for=#{theId}-none>+-    <div>+-        <input id=#{theId}-none type=radio name=#{name} value=none :isSel:checked>+-        _{MsgSelectNone}+-|])+-    (\theId name attrs value isSel text -> [whamlet|+-$newline never+-<label .radio for=#{theId}-#{value}>+-    <div>+-        <input id=#{theId}-#{value} type=radio name=#{name} value=#{value} :isSel:checked *{attrs}>+-        \#{text}+-|])++    (\theId _name _attrs inside ->     do { toWidget++           ((Text.Blaze.Internal.preEscapedText . pack) "<div id=\"");++         toWidget (Text.Blaze.Html.toHtml theId);++         toWidget ((Text.Blaze.Internal.preEscapedText . pack) "\">");++         toWidget inside;++         toWidget ((Text.Blaze.Internal.preEscapedText . pack) "</div>") })++++    (\theId name isSel ->     do { toWidget++           ((Text.Blaze.Internal.preEscapedText . pack)++              "<label class=\"radio\" for=\"");++         toWidget (Text.Blaze.Html.toHtml theId);++         toWidget++           ((Text.Blaze.Internal.preEscapedText . pack)++              "-none\"><div><input id=\"");++         toWidget (Text.Blaze.Html.toHtml theId);++         toWidget++           ((Text.Blaze.Internal.preEscapedText . pack)++              "-none\" type=\"radio\" name=\"");++         toWidget (Text.Blaze.Html.toHtml name);++         toWidget++           ((Text.Blaze.Internal.preEscapedText . pack) "\" value=\"none\"");++         Text.Hamlet.condH++           [(isSel, ++             toWidget ((Text.Blaze.Internal.preEscapedText . pack) " checked"))]++           Nothing;++         toWidget ((Text.Blaze.Internal.preEscapedText . pack) ">");++         (((Control.Monad.liftM (Text.Blaze.Html.toHtml .))++           $ (Yesod.Widget.liftW getMessageRender))++          >>= (\ urender_amQa -> toWidget (urender_amQa MsgSelectNone)));++         toWidget++           ((Text.Blaze.Internal.preEscapedText . pack) "</div></label>") })++++    (\theId name attrs value isSel text ->     do { toWidget++           ((Text.Blaze.Internal.preEscapedText . pack)++              "<label class=\"radio\" for=\"");++         toWidget (Text.Blaze.Html.toHtml theId);++         toWidget ((Text.Blaze.Internal.preEscapedText . pack) "-");++         toWidget (Text.Blaze.Html.toHtml value);++         toWidget++           ((Text.Blaze.Internal.preEscapedText . pack)++              "\"><div><input id=\"");++         toWidget (Text.Blaze.Html.toHtml theId);++         toWidget ((Text.Blaze.Internal.preEscapedText . pack) "-");++         toWidget (Text.Blaze.Html.toHtml value);++         toWidget++           ((Text.Blaze.Internal.preEscapedText . pack)++              "\" type=\"radio\" name=\"");++         toWidget (Text.Blaze.Html.toHtml name);++         toWidget++           ((Text.Blaze.Internal.preEscapedText . pack) "\" value=\"");++         toWidget (Text.Blaze.Html.toHtml value);++         toWidget ((Text.Blaze.Internal.preEscapedText . pack) "\"");++         Text.Hamlet.condH++           [(isSel, ++             toWidget ((Text.Blaze.Internal.preEscapedText . pack) " checked"))]++           Nothing;++         toWidget ((Text.Hamlet.attrsToHtml . toAttributes) attrs);++         toWidget ((Text.Blaze.Internal.preEscapedText . pack) ">");++         toWidget (Text.Blaze.Html.toHtml text);++         toWidget++           ((Text.Blaze.Internal.preEscapedText . pack) "</div></label>") })+++ + boolField :: RenderMessage master FormMessage => Field sub master Bool+ boolField = Field+       { fieldParse = \e _ -> return $ boolParser e+-      , fieldView = \theId name attrs val isReq -> [whamlet|+-$newline never+-  $if not isReq+-      <input id=#{theId}-none *{attrs} type=radio name=#{name} value=none checked>+-      <label for=#{theId}-none>_{MsgSelectNone}+-++      , fieldView = \theId name attrs val isReq ->       do { Text.Hamlet.condH++             [(not isReq, ++               do { toWidget++                      ((Text.Blaze.Internal.preEscapedText . pack) "<input id=\"");++                    toWidget (Text.Blaze.Html.toHtml theId);++                    toWidget++                      ((Text.Blaze.Internal.preEscapedText . pack)++                         "-none\" type=\"radio\" name=\"");++                    toWidget (Text.Blaze.Html.toHtml name);++                    toWidget++                      ((Text.Blaze.Internal.preEscapedText . pack)++                         "\" value=\"none\" checked");++                    toWidget ((Text.Hamlet.attrsToHtml . toAttributes) attrs);++                    toWidget++                      ((Text.Blaze.Internal.preEscapedText . pack) "><label for=\"");++                    toWidget (Text.Blaze.Html.toHtml theId);++                    toWidget ((Text.Blaze.Internal.preEscapedText . pack) "-none\">");++                    (((Control.Monad.liftM (Text.Blaze.Html.toHtml .))++                      $ (Yesod.Widget.liftW getMessageRender))++                     >>= (\ urender_amQx -> toWidget (urender_amQx MsgSelectNone)));++                    toWidget++                      ((Text.Blaze.Internal.preEscapedText . pack) "</label>") })]++             Nothing;++           toWidget++             ((Text.Blaze.Internal.preEscapedText . pack) "<input id=\"");++           toWidget (Text.Blaze.Html.toHtml theId);++           toWidget++             ((Text.Blaze.Internal.preEscapedText . pack)++                "-yes\" type=\"radio\" name=\"");++           toWidget (Text.Blaze.Html.toHtml name);++           toWidget++             ((Text.Blaze.Internal.preEscapedText . pack) "\" value=\"yes\"");++           Text.Hamlet.condH++             [(showVal id val, ++               toWidget ((Text.Blaze.Internal.preEscapedText . pack) " checked"))]++             Nothing;++           toWidget ((Text.Hamlet.attrsToHtml . toAttributes) attrs);++           toWidget++             ((Text.Blaze.Internal.preEscapedText . pack) "><label for=\"");++           toWidget (Text.Blaze.Html.toHtml theId);++           toWidget ((Text.Blaze.Internal.preEscapedText . pack) "-yes\">");++           (((Control.Monad.liftM (Text.Blaze.Html.toHtml .))++             $ (Yesod.Widget.liftW getMessageRender))++            >>= (\ urender_amQy -> toWidget (urender_amQy MsgBoolYes)));++           toWidget++             ((Text.Blaze.Internal.preEscapedText . pack)++                "</label><input id=\"");++           toWidget (Text.Blaze.Html.toHtml theId);++           toWidget++             ((Text.Blaze.Internal.preEscapedText . pack)++                "-no\" type=\"radio\" name=\"");++           toWidget (Text.Blaze.Html.toHtml name);++           toWidget++             ((Text.Blaze.Internal.preEscapedText . pack) "\" value=\"no\"");++           Text.Hamlet.condH++             [(showVal not val, ++               toWidget ((Text.Blaze.Internal.preEscapedText . pack) " checked"))]++             Nothing;++           toWidget ((Text.Hamlet.attrsToHtml . toAttributes) attrs);++           toWidget++             ((Text.Blaze.Internal.preEscapedText . pack) "><label for=\"");++           toWidget (Text.Blaze.Html.toHtml theId);++           toWidget ((Text.Blaze.Internal.preEscapedText . pack) "-no\">");++           (((Control.Monad.liftM (Text.Blaze.Html.toHtml .))++             $ (Yesod.Widget.liftW getMessageRender))++            >>= (\ urender_amQz -> toWidget (urender_amQz MsgBoolNo)));++           toWidget ((Text.Blaze.Internal.preEscapedText . pack) "</label>") }+ +-<input id=#{theId}-yes *{attrs} type=radio name=#{name} value=yes :showVal id val:checked>+-<label for=#{theId}-yes>_{MsgBoolYes}+-+-<input id=#{theId}-no *{attrs} type=radio name=#{name} value=no :showVal not val:checked>+-<label for=#{theId}-no>_{MsgBoolNo}+-|]+     , fieldEnctype = UrlEncoded+     }+   where+@@ -458,10 +805,22 @@ $newline never+ checkBoxField :: RenderMessage m FormMessage => Field s m Bool+ checkBoxField = Field+     { fieldParse = \e _ -> return $ checkBoxParser e+-    , fieldView  = \theId name attrs val _ -> [whamlet|+-$newline never+-<input id=#{theId} *{attrs} type=checkbox name=#{name} value=yes :showVal id val:checked>+-|]++    , fieldView  = \theId name attrs val _ ->     do { toWidget++           ((Text.Blaze.Internal.preEscapedText . pack) "<input id=\"");++         toWidget (Text.Blaze.Html.toHtml theId);++         toWidget++           ((Text.Blaze.Internal.preEscapedText . pack)++              "\" type=\"checkbox\" name=\"");++         toWidget (Text.Blaze.Html.toHtml name);++         toWidget++           ((Text.Blaze.Internal.preEscapedText . pack) "\" value=\"yes\"");++         Text.Hamlet.condH++           [(showVal id val, ++             toWidget ((Text.Blaze.Internal.preEscapedText . pack) " checked"))]++           Nothing;++         toWidget ((Text.Hamlet.attrsToHtml . toAttributes) attrs);++         toWidget ((Text.Blaze.Internal.preEscapedText . pack) ">") }+++     , fieldEnctype = UrlEncoded+     }+ +@@ -566,9 +925,21 @@ fileField = Field+         case files of+             [] -> Right Nothing+             file:_ -> Right $ Just file+-    , fieldView = \id' name attrs _ isReq -> toWidget [hamlet|+-            <input id=#{id'} name=#{name} *{attrs} type=file :isReq:required>+-        |]++    , fieldView = \id' name attrs _ isReq -> toWidget  $     \ _render_amRu++      -> do { id++                ((Text.Blaze.Internal.preEscapedText . pack) "<input id=\"");++              id (Text.Blaze.Html.toHtml id');++              id ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\"");++              id (Text.Blaze.Html.toHtml name);++              id++                ((Text.Blaze.Internal.preEscapedText . pack) "\" type=\"file\"");++              Text.Hamlet.condH++                [(isReq, ++                  id ((Text.Blaze.Internal.preEscapedText . pack) " required"))]++                Nothing;++              id ((Text.Hamlet.attrsToHtml . toAttributes) attrs);++              id ((Text.Blaze.Internal.preEscapedText . pack) ">") }+++     , fieldEnctype = Multipart+     }+ +@@ -594,10 +965,16 @@ fileAFormReq fs = AForm $ \(master, langs) menvs ints -> do+             { fvLabel = toHtml $ renderMessage master langs $ fsLabel fs+             , fvTooltip = fmap (toHtml . renderMessage master langs) $ fsTooltip fs+             , fvId = id'+-            , fvInput = [whamlet|+-$newline never+-<input type=file name=#{name} ##{id'} *{fsAttrs fs}>+-|]++            , fvInput =             do { toWidget++                   ((Text.Blaze.Internal.preEscapedText . pack)++                      "<input type=\"file\" name=\"");++                 toWidget (Text.Blaze.Html.toHtml name);++                 toWidget ((Text.Blaze.Internal.preEscapedText . pack) "\" id=\"");++                 toWidget (Text.Blaze.Html.toHtml id');++                 toWidget ((Text.Blaze.Internal.preEscapedText . pack) "\"");++                 toWidget ((Text.Hamlet.attrsToHtml . toAttributes) (fsAttrs fs));++                 toWidget ((Text.Blaze.Internal.preEscapedText . pack) ">") }+++             , fvErrors = errs+             , fvRequired = True+             }+@@ -623,10 +1000,16 @@ fileAFormOpt fs = AForm $ \(master, langs) menvs ints -> do+             { fvLabel = toHtml $ renderMessage master langs $ fsLabel fs+             , fvTooltip = fmap (toHtml . renderMessage master langs) $ fsTooltip fs+             , fvId = id'+-            , fvInput = [whamlet|+-$newline never+-<input type=file name=#{name} ##{id'} *{fsAttrs fs}>+-|]++            , fvInput =             do { toWidget++                   ((Text.Blaze.Internal.preEscapedText . pack)++                      "<input type=\"file\" name=\"");++                 toWidget (Text.Blaze.Html.toHtml name);++                 toWidget ((Text.Blaze.Internal.preEscapedText . pack) "\" id=\"");++                 toWidget (Text.Blaze.Html.toHtml id');++                 toWidget ((Text.Blaze.Internal.preEscapedText . pack) "\"");++                 toWidget ((Text.Hamlet.attrsToHtml . toAttributes) (fsAttrs fs));++                 toWidget ((Text.Blaze.Internal.preEscapedText . pack) ">") }+++             , fvErrors = errs+             , fvRequired = False+             }+diff --git a/Yesod/Form/Functions.hs b/Yesod/Form/Functions.hs+index 89eb1e8..54974bb 100644+--- a/Yesod/Form/Functions.hs++++ b/Yesod/Form/Functions.hs+@@ -42,6 +42,15 @@ module Yesod.Form.Functions+     , parseHelper+     ) where+ ++import qualified Data.Text.Lazy.Builder++import qualified Text.Shakespeare++import qualified Data.Monoid++import qualified Text.Julius++import qualified "blaze-markup" Text.Blaze.Internal++import qualified "blaze-markup" Text.Blaze as Text.Blaze.Markup++import qualified Yesod.Widget++import qualified Data.Foldable++import qualified Text.Hamlet+ import Yesod.Form.Types+ import Data.Text (Text, pack)+ import Control.Arrow (second)+@@ -191,10 +200,13 @@ postHelper form env = do+     let token =+             case reqToken req of+                 Nothing -> mempty+-                Just n -> [shamlet|+-$newline never+-<input type=hidden name=#{tokenKey} value=#{n}>+-|]++                Just n -> do { id++       ((Text.Blaze.Internal.preEscapedText . pack)++          "<input type=\"hidden\" name=\"");++     id (Text.Blaze.Html.toHtml tokenKey);++     id ((Text.Blaze.Internal.preEscapedText . pack) "\" value=\"");++     id (Text.Blaze.Html.toHtml n);++     id ((Text.Blaze.Internal.preEscapedText . pack) "\">") }+     m <- getYesod+     langs <- languages+     ((res, xml), enctype) <- runFormGeneric (form token) m langs env+@@ -253,10 +265,11 @@ getKey = "_hasdata"+ + getHelper :: (Html -> MForm sub master a) -> Maybe (Env, FileEnv) -> GHandler sub master (a, Enctype)+ getHelper form env = do+-    let fragment = [shamlet|+-$newline never+-<input type=hidden name=#{getKey}>+-|]++    let fragment = do { id++       ((Text.Blaze.Internal.preEscapedText . pack)++          "<input type=\"hidden\" name=\"");++     id (Text.Blaze.Html.toHtml getKey);++     id ((Text.Blaze.Internal.preEscapedText . pack) "\">") }+     langs <- languages+     m <- getYesod+     runFormGeneric (form fragment) m langs env+@@ -270,19 +283,64 @@ renderTable, renderDivs, renderDivsNoLabels :: FormRender sub master a+ renderTable aform fragment = do+     (res, views') <- aFormToForm aform+     let views = views' []+-    let widget = [whamlet|+-$newline never+-\#{fragment}+-$forall view <- views+-    <tr :fvRequired view:.required :not $ fvRequired view:.optional>+-        <td>+-            <label for=#{fvId view}>#{fvLabel view}+-            $maybe tt <- fvTooltip view+-                <div .tooltip>#{tt}+-        <td>^{fvInput view}+-        $maybe err <- fvErrors view+-            <td .errors>#{err}+-|]++    let widget = do { Yesod.Widget.toWidget (Text.Blaze.Html.toHtml fragment);++     Data.Foldable.mapM_++       (\ view_a9GR++          -> do { Yesod.Widget.toWidget++                    ((Text.Blaze.Internal.preEscapedText . pack) "<tr");++                  Text.Hamlet.condH++                    [(or [fvRequired view_a9GR, not (fvRequired view_a9GR)], ++                      do { Yesod.Widget.toWidget++                             ((Text.Blaze.Internal.preEscapedText . pack) " class=\"");++                           Text.Hamlet.condH++                             [(fvRequired view_a9GR, ++                               Yesod.Widget.toWidget++                                 ((Text.Blaze.Internal.preEscapedText . pack) "required "))]++                             Nothing;++                           Text.Hamlet.condH++                             [(not (fvRequired view_a9GR), ++                               Yesod.Widget.toWidget++                                 ((Text.Blaze.Internal.preEscapedText . pack) "optional"))]++                             Nothing;++                           Yesod.Widget.toWidget++                             ((Text.Blaze.Internal.preEscapedText . pack) "\"") })]++                    Nothing;++                  Yesod.Widget.toWidget++                    ((Text.Blaze.Internal.preEscapedText . pack) "><td><label for=\"");++                  Yesod.Widget.toWidget (Text.Blaze.Html.toHtml (fvId view_a9GR));++                  Yesod.Widget.toWidget++                    ((Text.Blaze.Internal.preEscapedText . pack) "\">");++                  Yesod.Widget.toWidget (Text.Blaze.Html.toHtml (fvLabel view_a9GR));++                  Yesod.Widget.toWidget++                    ((Text.Blaze.Internal.preEscapedText . pack) "</label>");++                  Text.Hamlet.maybeH++                    (fvTooltip view_a9GR)++                    (\ tt_a9GS++                       -> do { Yesod.Widget.toWidget++                                 ((Text.Blaze.Internal.preEscapedText . pack)++                                    "<div class=\"tooltip\">");++                               Yesod.Widget.toWidget (Text.Blaze.Html.toHtml tt_a9GS);++                               Yesod.Widget.toWidget++                                 ((Text.Blaze.Internal.preEscapedText . pack) "</div>") })++                    Nothing;++                  Yesod.Widget.toWidget++                    ((Text.Blaze.Internal.preEscapedText . pack) "</td><td>");++                  Yesod.Widget.toWidget (fvInput view_a9GR);++                  Yesod.Widget.toWidget++                    ((Text.Blaze.Internal.preEscapedText . pack) "</td>");++                  Text.Hamlet.maybeH++                    (fvErrors view_a9GR)++                    (\ err_a9GT++                       -> do { Yesod.Widget.toWidget++                                 ((Text.Blaze.Internal.preEscapedText . pack)++                                    "<td class=\"errors\">");++                               Yesod.Widget.toWidget (Text.Blaze.Html.toHtml err_a9GT);++                               Yesod.Widget.toWidget++                                 ((Text.Blaze.Internal.preEscapedText . pack) "</td>") })++                    Nothing;++                  Yesod.Widget.toWidget++                    ((Text.Blaze.Internal.preEscapedText . pack) "</tr>") })++       views }+     return (res, widget)+ + -- | render a field inside a div+@@ -295,19 +353,65 @@ renderDivsMaybeLabels :: Bool -> FormRender sub master a+ renderDivsMaybeLabels withLabels aform fragment = do+     (res, views') <- aFormToForm aform+     let views = views' []+-    let widget = [whamlet|+-$newline never+-\#{fragment}+-$forall view <- views+-    <div :fvRequired view:.required :not $ fvRequired view:.optional>+-        $if withLabels+-                <label for=#{fvId view}>#{fvLabel view}+-        $maybe tt <- fvTooltip view+-            <div .tooltip>#{tt}+-        ^{fvInput view}+-        $maybe err <- fvErrors view+-            <div .errors>#{err}+-|]++    let widget = do { Yesod.Widget.toWidget (Text.Blaze.Html.toHtml fragment);++     Data.Foldable.mapM_++       (\ view_a9Hr++          -> do { Yesod.Widget.toWidget++                    ((Text.Blaze.Internal.preEscapedText . pack) "<div");++                  Text.Hamlet.condH++                    [(or [fvRequired view_a9Hr, not (fvRequired view_a9Hr)], ++                      do { Yesod.Widget.toWidget++                             ((Text.Blaze.Internal.preEscapedText . pack) " class=\"");++                           Text.Hamlet.condH++                             [(fvRequired view_a9Hr, ++                               Yesod.Widget.toWidget++                                 ((Text.Blaze.Internal.preEscapedText . pack) "required "))]++                             Nothing;++                           Text.Hamlet.condH++                             [(not (fvRequired view_a9Hr), ++                               Yesod.Widget.toWidget++                                 ((Text.Blaze.Internal.preEscapedText . pack) "optional"))]++                             Nothing;++                           Yesod.Widget.toWidget++                             ((Text.Blaze.Internal.preEscapedText . pack) "\"") })]++                    Nothing;++                  Yesod.Widget.toWidget++                    ((Text.Blaze.Internal.preEscapedText . pack) ">");++                  Text.Hamlet.condH++                    [(withLabels, ++                      do { Yesod.Widget.toWidget++                             ((Text.Blaze.Internal.preEscapedText . pack) "<label for=\"");++                           Yesod.Widget.toWidget (Text.Blaze.Html.toHtml (fvId view_a9Hr));++                           Yesod.Widget.toWidget++                             ((Text.Blaze.Internal.preEscapedText . pack) "\">");++                           Yesod.Widget.toWidget (Text.Blaze.Html.toHtml (fvLabel view_a9Hr));++                           Yesod.Widget.toWidget++                             ((Text.Blaze.Internal.preEscapedText . pack) "</label>") })]++                    Nothing;++                  Text.Hamlet.maybeH++                    (fvTooltip view_a9Hr)++                    (\ tt_a9Hs++                       -> do { Yesod.Widget.toWidget++                                 ((Text.Blaze.Internal.preEscapedText . pack)++                                    "<div class=\"tooltip\">");++                               Yesod.Widget.toWidget (Text.Blaze.Html.toHtml tt_a9Hs);++                               Yesod.Widget.toWidget++                                 ((Text.Blaze.Internal.preEscapedText . pack) "</div>") })++                    Nothing;++                  Yesod.Widget.toWidget (fvInput view_a9Hr);++                  Text.Hamlet.maybeH++                    (fvErrors view_a9Hr)++                    (\ err_a9Ht++                       -> do { Yesod.Widget.toWidget++                                 ((Text.Blaze.Internal.preEscapedText . pack)++                                    "<div class=\"errors\">");++                               Yesod.Widget.toWidget (Text.Blaze.Html.toHtml err_a9Ht);++                               Yesod.Widget.toWidget++                                 ((Text.Blaze.Internal.preEscapedText . pack) "</div>") })++                    Nothing;++                  Yesod.Widget.toWidget++                    ((Text.Blaze.Internal.preEscapedText . pack) "</div>") })++       views }+     return (res, widget)+ + -- | Render a form using Bootstrap-friendly shamlet syntax.+@@ -331,19 +435,61 @@ renderBootstrap aform fragment = do+     let views = views' []+         has (Just _) = True+         has Nothing  = False+-    let widget = [whamlet|+-$newline never+-\#{fragment}+-$forall view <- views+-    <div .control-group .clearfix :fvRequired view:.required :not $ fvRequired view:.optional :has $ fvErrors view:.error>+-        <label .control-label for=#{fvId view}>#{fvLabel view}+-        <div .controls .input>+-            ^{fvInput view}+-            $maybe tt <- fvTooltip view+-                <span .help-block>#{tt}+-            $maybe err <- fvErrors view+-                <span .help-block>#{err}+-|]++    let widget = do { Yesod.Widget.toWidget (Text.Blaze.Html.toHtml fragment);++     Data.Foldable.mapM_++       (\ view_a9HE++          -> do { Yesod.Widget.toWidget++                    ((Text.Blaze.Internal.preEscapedText . pack)++                       "<div class=\"control-group clearfix ");++                  Text.Hamlet.condH++                    [(fvRequired view_a9HE, ++                      Yesod.Widget.toWidget++                        ((Text.Blaze.Internal.preEscapedText . pack) "required "))]++                    Nothing;++                  Text.Hamlet.condH++                    [(not (fvRequired view_a9HE), ++                      Yesod.Widget.toWidget++                        ((Text.Blaze.Internal.preEscapedText . pack) "optional "))]++                    Nothing;++                  Text.Hamlet.condH++                    [(has (fvErrors view_a9HE), ++                      Yesod.Widget.toWidget++                        ((Text.Blaze.Internal.preEscapedText . pack) "error"))]++                    Nothing;++                  Yesod.Widget.toWidget++                    ((Text.Blaze.Internal.preEscapedText . pack)++                       "\"><label class=\"control-label\" for=\"");++                  Yesod.Widget.toWidget (Text.Blaze.Html.toHtml (fvId view_a9HE));++                  Yesod.Widget.toWidget++                    ((Text.Blaze.Internal.preEscapedText . pack) "\">");++                  Yesod.Widget.toWidget (Text.Blaze.Html.toHtml (fvLabel view_a9HE));++                  Yesod.Widget.toWidget++                    ((Text.Blaze.Internal.preEscapedText . pack)++                       "</label><div class=\"controls input\">");++                  Yesod.Widget.toWidget (fvInput view_a9HE);++                  Text.Hamlet.maybeH++                    (fvTooltip view_a9HE)++                    (\ tt_a9HF++                       -> do { Yesod.Widget.toWidget++                                 ((Text.Blaze.Internal.preEscapedText . pack)++                                    "<span class=\"help-block\">");++                               Yesod.Widget.toWidget (Text.Blaze.Html.toHtml tt_a9HF);++                               Yesod.Widget.toWidget++                                 ((Text.Blaze.Internal.preEscapedText . pack) "</span>") })++                    Nothing;++                  Text.Hamlet.maybeH++                    (fvErrors view_a9HE)++                    (\ err_a9HG++                       -> do { Yesod.Widget.toWidget++                                 ((Text.Blaze.Internal.preEscapedText . pack)++                                    "<span class=\"help-block\">");++                               Yesod.Widget.toWidget (Text.Blaze.Html.toHtml err_a9HG);++                               Yesod.Widget.toWidget++                                 ((Text.Blaze.Internal.preEscapedText . pack) "</span>") })++                    Nothing;++                  Yesod.Widget.toWidget++                    ((Text.Blaze.Internal.preEscapedText . pack) "</div></div>") })++       views }+     return (res, widget)+ + check :: RenderMessage master msg+diff --git a/Yesod/Form/Jquery.hs b/Yesod/Form/Jquery.hs+index 85a0c76..70ac315 100644+--- a/Yesod/Form/Jquery.hs++++ b/Yesod/Form/Jquery.hs+@@ -12,14 +12,22 @@ module Yesod.Form.Jquery+     , Default (..)+     ) where+ ++import qualified Data.Text.Lazy.Builder++import qualified Text.Shakespeare++import qualified Data.Monoid++import qualified Text.Julius++import qualified "blaze-markup" Text.Blaze.Internal++import qualified "blaze-html" Text.Blaze.Html++import qualified Yesod.Widget++import qualified Text.Hamlet++import qualified Text.Julius+ import Yesod.Handler+ import Yesod.Core (Route)+ import Yesod.Form+ import Yesod.Widget+ import Data.Time (Day)+ import Data.Default+-import Text.Hamlet (shamlet)+-import Text.Julius (julius, rawJS)++import Text.Julius (rawJS)+ import Data.Text (Text, pack, unpack)+ import Data.Monoid (mconcat)+ import Yesod.Core (RenderMessage)+@@ -64,27 +72,75 @@ jqueryDayField jds = Field+               . readMay+               . unpack+     , fieldView = \theId name attrs val isReq -> do+-        toWidget [shamlet|+-$newline never+-<input id="#{theId}" name="#{name}" *{attrs} type="date" :isReq:required="" value="#{showVal val}">+-|]++        toWidget  $         do { id++               ((Text.Blaze.Internal.preEscapedText . pack) "<input id=\"");++             id (Text.Blaze.Html.toHtml theId);++             id ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\"");++             id (Text.Blaze.Html.toHtml name);++             id++               ((Text.Blaze.Internal.preEscapedText . pack) "\" type=\"date\"");++             Text.Hamlet.condH++               [(isReq, ++                 id ((Text.Blaze.Internal.preEscapedText . pack) " required=\"\""))]++               Nothing;++             id ((Text.Blaze.Internal.preEscapedText . pack) " value=\"");++             id (Text.Blaze.Html.toHtml (showVal val));++             id ((Text.Blaze.Internal.preEscapedText . pack) "\"");++             id ((Text.Hamlet.attrsToHtml . Text.Hamlet.toAttributes) attrs);++             id ((Text.Blaze.Internal.preEscapedText . pack) ">") }+++         addScript' urlJqueryJs+         addScript' urlJqueryUiJs+         addStylesheet' urlJqueryUiCss+-        toWidget [julius|+-$(function(){+-    var i = document.getElementById("#{rawJS theId}");+-    if (i.type != "date") {+-        $(i).datepicker({+-            dateFormat:'yy-mm-dd',+-            changeMonth:#{jsBool $ jdsChangeMonth jds},+-            changeYear:#{jsBool $ jdsChangeYear jds},+-            numberOfMonths:#{rawJS $ mos $ jdsNumberOfMonths jds},+-            yearRange:#{toJSON $ jdsYearRange jds}+-        });+-    }+-});+-|]++        toWidget  $         Text.Julius.asJavascriptUrl++          (\ _render_a1esc++             -> mconcat++                  [Text.Julius.Javascript++                     ((Data.Text.Lazy.Builder.fromText++                       . Text.Shakespeare.pack')++                        "\++                        \$(function(){\++                        \    var i = document.getElementById(\""),++                   Text.Julius.Javascript (Text.Julius.toJavascript (rawJS theId)),++                   Text.Julius.Javascript++                     ((Data.Text.Lazy.Builder.fromText++                       . Text.Shakespeare.pack')++                        "\");\++                        \    if (i.type != \"date\") {\++                        \        $(i).datepicker({\++                        \            'yy-mm-dd',\++                        \            changeMonth:"),++                   Text.Julius.Javascript++                     (Text.Julius.toJavascript (jsBool (jdsChangeMonth jds))),++                   Text.Julius.Javascript++                     ((Data.Text.Lazy.Builder.fromText++                       . Text.Shakespeare.pack')++                        ",\++                        \            changeYear:"),++                   Text.Julius.Javascript++                     (Text.Julius.toJavascript (jsBool (jdsChangeYear jds))),++                   Text.Julius.Javascript++                     ((Data.Text.Lazy.Builder.fromText++                       . Text.Shakespeare.pack')++                        ",\++                        \            numberOfMonths:"),++                   Text.Julius.Javascript++                     (Text.Julius.toJavascript (rawJS (mos (jdsNumberOfMonths jds)))),++                   Text.Julius.Javascript++                     ((Data.Text.Lazy.Builder.fromText++                       . Text.Shakespeare.pack')++                        ",\++                        \            yearRange:"),++                   Text.Julius.Javascript++                     (Text.Julius.toJavascript (toJSON (jdsYearRange jds))),++                   Text.Julius.Javascript++                     ((Data.Text.Lazy.Builder.fromText++                       . Text.Shakespeare.pack')++                        "\++                        \        });\++                        \    }\++                        \});")])+++     , fieldEnctype = UrlEncoded+     }+   where+@@ -105,16 +161,47 @@ jqueryAutocompleteField :: (RenderMessage master FormMessage, YesodJquery master+ jqueryAutocompleteField src = Field+     { fieldParse = parseHelper $ Right+     , fieldView = \theId name attrs val isReq -> do+-        toWidget [shamlet|+-$newline never+-<input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required="" value="#{either id id val}" .autocomplete>+-|]++        toWidget  $         do { id++               ((Text.Blaze.Internal.preEscapedText . pack)++                  "<input class=\"autocomplete\" id=\"");++             id (Text.Blaze.Html.toHtml theId);++             id ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\"");++             id (Text.Blaze.Html.toHtml name);++             id++               ((Text.Blaze.Internal.preEscapedText . pack) "\" type=\"text\"");++             Text.Hamlet.condH++               [(isReq, ++                 id ((Text.Blaze.Internal.preEscapedText . pack) " required=\"\""))]++               Nothing;++             id ((Text.Blaze.Internal.preEscapedText . pack) " value=\"");++             id (Text.Blaze.Html.toHtml (either id id val));++             id ((Text.Blaze.Internal.preEscapedText . pack) "\"");++             id ((Text.Hamlet.attrsToHtml . Text.Hamlet.toAttributes) attrs);++             id ((Text.Blaze.Internal.preEscapedText . pack) ">") }+++         addScript' urlJqueryJs+         addScript' urlJqueryUiJs+         addStylesheet' urlJqueryUiCss+-        toWidget [julius|+-$(function(){$("##{rawJS theId}").autocomplete({source:"@{src}",minLength:2})});+-|]++        toWidget  $         Text.Julius.asJavascriptUrl++          (\ _render_a1esq++             -> mconcat++                  [Text.Julius.Javascript++                     ((Data.Text.Lazy.Builder.fromText++                       . Text.Shakespeare.pack')++                        "\++                        \$(function(){$(\"#"),++                   Text.Julius.Javascript (Text.Julius.toJavascript (rawJS theId)),++                   Text.Julius.Javascript++                     ((Data.Text.Lazy.Builder.fromText++                       . Text.Shakespeare.pack')++                        "\").autocomplete({source:\""),++                   Text.Julius.Javascript++                     (Data.Text.Lazy.Builder.fromText (_render_a1esq src [])),++                   Text.Julius.Javascript++                     ((Data.Text.Lazy.Builder.fromText++                       . Text.Shakespeare.pack')++                        "\",2})});")])+++     , fieldEnctype = UrlEncoded+     }+ +diff --git a/Yesod/Form/MassInput.hs b/Yesod/Form/MassInput.hs+index 62e89d6..22fdad5 100644+--- a/Yesod/Form/MassInput.hs++++ b/Yesod/Form/MassInput.hs+@@ -9,10 +9,20 @@ module Yesod.Form.MassInput+     , massTable+     ) where+ ++import qualified Data.Text.Lazy.Builder++import qualified Text.Shakespeare++import qualified Data.Monoid++import qualified Text.Julius++import qualified "blaze-markup" Text.Blaze.Internal++import qualified "blaze-html" Text.Blaze.Html++import qualified Yesod.Widget++import qualified Data.Text++import qualified Text.Hamlet++import qualified Data.Foldable+ import Yesod.Form.Types+ import Yesod.Form.Functions+ import Yesod.Form.Fields (boolField)+-import Yesod.Widget (GWidget, whamlet)++import Yesod.Widget (GWidget)+ import Yesod.Message (RenderMessage)+ import Yesod.Handler (newIdent, GHandler)+ import Text.Blaze.Html (Html)+@@ -75,16 +85,27 @@ inputList label fixXml single mdef = formToAForm $ do+         { fvLabel = label+         , fvTooltip = Nothing+         , fvId = theId+-        , fvInput = [whamlet|+-$newline never+-^{fixXml views}+-<p>+-    $forall xml <- xmls+-        ^{xml}+-    <input .count type=hidden name=#{countName} value=#{count}>+-    <input type=checkbox name=#{addName}>+-    Add another row+-|]++        , fvInput =         do { Yesod.Widget.toWidget (fixXml views);++             Yesod.Widget.toWidget++               ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) "<p>");++             Data.Foldable.mapM_++               (\ xml_aOR7 -> Yesod.Widget.toWidget xml_aOR7) xmls;++             Yesod.Widget.toWidget++               ((Text.Blaze.Internal.preEscapedText . Data.Text.pack)++                  "<input class=\"count\" type=\"hidden\" name=\"");++             Yesod.Widget.toWidget (Text.Blaze.Html.toHtml countName);++             Yesod.Widget.toWidget++               ((Text.Blaze.Internal.preEscapedText . Data.Text.pack)++                  "\" value=\"");++             Yesod.Widget.toWidget (Text.Blaze.Html.toHtml count);++             Yesod.Widget.toWidget++               ((Text.Blaze.Internal.preEscapedText . Data.Text.pack)++                  "\"><input type=\"checkbox\" name=\"");++             Yesod.Widget.toWidget (Text.Blaze.Html.toHtml addName);++             Yesod.Widget.toWidget++               ((Text.Blaze.Internal.preEscapedText . Data.Text.pack)++                  "\">Add another row</p>") }+++         , fvErrors = Nothing+         , fvRequired = False+         }])+@@ -97,10 +118,14 @@ withDelete af = do+     deleteName <- newFormIdent+     (menv, _, _) <- ask+     res <- case menv >>= Map.lookup deleteName . fst of+-        Just ("yes":_) -> return $ Left [whamlet|+-$newline never+-<input type=hidden name=#{deleteName} value=yes>+-|]++        Just ("yes":_) -> return $ Left  $         do { Yesod.Widget.toWidget++               ((Text.Blaze.Internal.preEscapedText . Data.Text.pack)++                  "<input type=\"hidden\" name=\"");++             Yesod.Widget.toWidget (Text.Blaze.Html.toHtml deleteName);++             Yesod.Widget.toWidget++               ((Text.Blaze.Internal.preEscapedText . Data.Text.pack)++                  "\" value=\"yes\">") }+++         _ -> do+             (_, xml2) <- aFormToForm $ areq boolField FieldSettings+                 { fsLabel = SomeMessage MsgDelete+@@ -126,32 +151,149 @@ fixme eithers =+ massDivs, massTable+          :: [[FieldView sub master]]+          -> GWidget sub master ()+-massDivs viewss = [whamlet|+-$newline never+-$forall views <- viewss+-    <fieldset>+-        $forall view <- views+-            <div :fvRequired view:.required :not $ fvRequired view:.optional>+-                <label for=#{fvId view}>#{fvLabel view}+-                $maybe tt <- fvTooltip view+-                    <div .tooltip>#{tt}+-                ^{fvInput view}+-                $maybe err <- fvErrors view+-                    <div .errors>#{err}+-|]++massDivs viewss = Data.Foldable.mapM_++  (\ views_aORq++     -> do { Yesod.Widget.toWidget++               ((Text.Blaze.Internal.preEscapedText . Data.Text.pack)++                  "<fieldset>");++             Data.Foldable.mapM_++               (\ view_aORr++                  -> do { Yesod.Widget.toWidget++                            ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) "<div");++                          Text.Hamlet.condH++                            [(or [fvRequired view_aORr, not (fvRequired view_aORr)], ++                              do { Yesod.Widget.toWidget++                                     ((Text.Blaze.Internal.preEscapedText . Data.Text.pack)++                                        " class=\"");++                                   Text.Hamlet.condH++                                     [(fvRequired view_aORr, ++                                       Yesod.Widget.toWidget++                                         ((Text.Blaze.Internal.preEscapedText . Data.Text.pack)++                                            "required "))]++                                     Nothing;++                                   Text.Hamlet.condH++                                     [(not (fvRequired view_aORr), ++                                       Yesod.Widget.toWidget++                                         ((Text.Blaze.Internal.preEscapedText . Data.Text.pack)++                                            "optional"))]++                                     Nothing;++                                   Yesod.Widget.toWidget++                                     ((Text.Blaze.Internal.preEscapedText . Data.Text.pack)++                                        "\"") })]++                            Nothing;++                          Yesod.Widget.toWidget++                            ((Text.Blaze.Internal.preEscapedText . Data.Text.pack)++                               "><label for=\"");++                          Yesod.Widget.toWidget (Text.Blaze.Html.toHtml (fvId view_aORr));++                          Yesod.Widget.toWidget++                            ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) "\">");++                          Yesod.Widget.toWidget (Text.Blaze.Html.toHtml (fvLabel view_aORr));++                          Yesod.Widget.toWidget++                            ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) "</label>");++                          Text.Hamlet.maybeH++                            (fvTooltip view_aORr)++                            (\ tt_aORs++                               -> do { Yesod.Widget.toWidget++                                         ((Text.Blaze.Internal.preEscapedText . Data.Text.pack)++                                            "<div class=\"tooltip\">");++                                       Yesod.Widget.toWidget (Text.Blaze.Html.toHtml tt_aORs);++                                       Yesod.Widget.toWidget++                                         ((Text.Blaze.Internal.preEscapedText . Data.Text.pack)++                                            "</div>") })++                            Nothing;++                          Yesod.Widget.toWidget (fvInput view_aORr);++                          Text.Hamlet.maybeH++                            (fvErrors view_aORr)++                            (\ err_aORt++                               -> do { Yesod.Widget.toWidget++                                         ((Text.Blaze.Internal.preEscapedText . Data.Text.pack)++                                            "<div class=\"errors\">");++                                       Yesod.Widget.toWidget (Text.Blaze.Html.toHtml err_aORt);++                                       Yesod.Widget.toWidget++                                         ((Text.Blaze.Internal.preEscapedText . Data.Text.pack)++                                            "</div>") })++                            Nothing;++                          Yesod.Widget.toWidget++                            ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) "</div>") })++               views_aORq;++             Yesod.Widget.toWidget++               ((Text.Blaze.Internal.preEscapedText . Data.Text.pack)++                  "</fieldset>") })++  viewss++++++massTable viewss = Data.Foldable.mapM_++  (\ views_aORy++     -> do { Yesod.Widget.toWidget++               ((Text.Blaze.Internal.preEscapedText . Data.Text.pack)++                  "<fieldset><table>");++             Data.Foldable.mapM_++               (\ view_aORz++                  -> do { Yesod.Widget.toWidget++                            ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) "<tr");++                          Text.Hamlet.condH++                            [(or [fvRequired view_aORz, not (fvRequired view_aORz)], ++                              do { Yesod.Widget.toWidget++                                     ((Text.Blaze.Internal.preEscapedText . Data.Text.pack)++                                        " class=\"");++                                   Text.Hamlet.condH++                                     [(fvRequired view_aORz, ++                                       Yesod.Widget.toWidget++                                         ((Text.Blaze.Internal.preEscapedText . Data.Text.pack)++                                            "required "))]++                                     Nothing;++                                   Text.Hamlet.condH++                                     [(not (fvRequired view_aORz), ++                                       Yesod.Widget.toWidget++                                         ((Text.Blaze.Internal.preEscapedText . Data.Text.pack)++                                            "optional"))]++                                     Nothing;++                                   Yesod.Widget.toWidget++                                     ((Text.Blaze.Internal.preEscapedText . Data.Text.pack)++                                        "\"") })]++                            Nothing;++                          Yesod.Widget.toWidget++                            ((Text.Blaze.Internal.preEscapedText . Data.Text.pack)++                               "><td><label for=\"");++                          Yesod.Widget.toWidget (Text.Blaze.Html.toHtml (fvId view_aORz));++                          Yesod.Widget.toWidget++                            ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) "\">");++                          Yesod.Widget.toWidget (Text.Blaze.Html.toHtml (fvLabel view_aORz));++                          Yesod.Widget.toWidget++                            ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) "</label>");++                          Text.Hamlet.maybeH++                            (fvTooltip view_aORz)++                            (\ tt_aORA++                               -> do { Yesod.Widget.toWidget++                                         ((Text.Blaze.Internal.preEscapedText . Data.Text.pack)++                                            "<div class=\"tooltip\">");++                                       Yesod.Widget.toWidget (Text.Blaze.Html.toHtml tt_aORA);++                                       Yesod.Widget.toWidget++                                         ((Text.Blaze.Internal.preEscapedText . Data.Text.pack)++                                            "</div>") })++                            Nothing;++                          Yesod.Widget.toWidget++                            ((Text.Blaze.Internal.preEscapedText . Data.Text.pack)++                               "</td><td>");++                          Yesod.Widget.toWidget (fvInput view_aORz);++                          Yesod.Widget.toWidget++                            ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) "</td>");++                          Text.Hamlet.maybeH++                            (fvErrors view_aORz)++                            (\ err_aORB++                               -> do { Yesod.Widget.toWidget++                                         ((Text.Blaze.Internal.preEscapedText . Data.Text.pack)++                                            "<td class=\"errors\">");++                                       Yesod.Widget.toWidget (Text.Blaze.Html.toHtml err_aORB);++                                       Yesod.Widget.toWidget++                                         ((Text.Blaze.Internal.preEscapedText . Data.Text.pack)++                                            "</td>") })++                            Nothing;++                          Yesod.Widget.toWidget++                            ((Text.Blaze.Internal.preEscapedText . Data.Text.pack) "</tr>") })++               views_aORy;++             Yesod.Widget.toWidget++               ((Text.Blaze.Internal.preEscapedText . Data.Text.pack)++                  "</table></fieldset>") })++  viewss+ +-massTable viewss = [whamlet|+-$newline never+-$forall views <- viewss+-    <fieldset>+-        <table>+-            $forall view <- views+-                <tr :fvRequired view:.required :not $ fvRequired view:.optional>+-                    <td>+-                        <label for=#{fvId view}>#{fvLabel view}+-                        $maybe tt <- fvTooltip view+-                            <div .tooltip>#{tt}+-                    <td>^{fvInput view}+-                    $maybe err <- fvErrors view+-                        <td .errors>#{err}+-|]+diff --git a/Yesod/Form/Nic.hs b/Yesod/Form/Nic.hs+index 7c65ce4..357532f 100644+--- a/Yesod/Form/Nic.hs++++ b/Yesod/Form/Nic.hs+@@ -9,13 +9,19 @@ module Yesod.Form.Nic+     , nicHtmlField+     ) where+ ++import qualified Data.Text.Lazy.Builder++import qualified Text.Shakespeare++import qualified Data.Monoid++import qualified Text.Julius++import qualified "blaze-markup" Text.Blaze.Internal++import qualified Yesod.Widget+ import Yesod.Handler+ import Yesod.Core (Route, ScriptLoadPosition(..), jsLoader, Yesod)+ import Yesod.Form+ import Yesod.Widget+ import Text.HTML.SanitizeXSS (sanitizeBalance)+-import Text.Hamlet (Html, shamlet)+-import Text.Julius (julius, rawJS)++import Text.Hamlet (Html)++import Text.Julius (rawJS)+ #if MIN_VERSION_blaze_html(0, 5, 0)+ import Text.Blaze (preEscapedToMarkup)+ import Text.Blaze.Html.Renderer.String (renderHtml)+@@ -36,20 +42,49 @@ nicHtmlField :: YesodNic master => Field sub master Html+ nicHtmlField = Field+     { fieldParse = \e _ -> return . Right . fmap (preEscapedText . sanitizeBalance) . listToMaybe $ e+     , fieldView = \theId name attrs val _isReq -> do+-        toWidget [shamlet|+-$newline never+-    <textarea id="#{theId}" *{attrs} name="#{name}" .html>#{showVal val}+-|]++        toWidget  $         do { id++               ((Text.Blaze.Internal.preEscapedText . pack)++                  "<textarea class=\"html\" id=\"");++             id (Text.Blaze.Html.toHtml theId);++             id ((Text.Blaze.Internal.preEscapedText . pack) "\" name=\"");++             id (Text.Blaze.Html.toHtml name);++             id ((Text.Blaze.Internal.preEscapedText . pack) "\"");++             id ((Text.Hamlet.attrsToHtml . Text.Hamlet.toAttributes) attrs);++             id ((Text.Blaze.Internal.preEscapedText . pack) ">");++             id (Text.Blaze.Html.toHtml (showVal val));++             id ((Text.Blaze.Internal.preEscapedText . pack) "</textarea>") }+++         addScript' urlNicEdit+         master <- lift getYesod+         toWidget $+           case jsLoader master of+-            BottomOfHeadBlocking -> [julius|+-bkLib.onDomLoaded(function(){new nicEditor({fullPanel:true}).panelInstance("#{rawJS theId}")});+-|]+-            _ -> [julius|+-(function(){new nicEditor({fullPanel:true}).panelInstance("#{rawJS theId}")})();+-|]++            BottomOfHeadBlocking ->             Text.Julius.asJavascriptUrl++              (\ _render_a1itM++                 -> Data.Monoid.mconcat++                      [Text.Julius.Javascript++                         ((Data.Text.Lazy.Builder.fromText++                           . Text.Shakespeare.pack')++                            "\++                            \bkLib.onDomLoaded(function(){new nicEditor({true}).panelInstance(\""),++                       Text.Julius.Javascript (Text.Julius.toJavascript (rawJS theId)),++                       Text.Julius.Javascript++                         ((Data.Text.Lazy.Builder.fromText++                           . Text.Shakespeare.pack')++                            "\")});")])++++            _ ->             Text.Julius.asJavascriptUrl++              (\ _render_a1itQ++                 -> Data.Monoid.mconcat++                      [Text.Julius.Javascript++                         ((Data.Text.Lazy.Builder.fromText++                           . Text.Shakespeare.pack')++                            "(function(){new nicEditor({true}).panelInstance(\""),++                       Text.Julius.Javascript (Text.Julius.toJavascript (rawJS theId)),++                       Text.Julius.Javascript++                         ((Data.Text.Lazy.Builder.fromText++                           . Text.Shakespeare.pack')++                            "\")})();")])+++     , fieldEnctype = UrlEncoded+     }+   where+-- +1.8.2.rc3+
+ standalone/android/haskell-patches/yesod-static-1.1.2-remove-TH.patch view
@@ -0,0 +1,187 @@+From 476414b04064bb66fc25ba9ca426c309fe5c156e Mon Sep 17 00:00:00 2001+From: Joey Hess <joey@kitenet.net>+Date: Mon, 15 Apr 2013 12:48:13 -0400+Subject: [PATCH] remove TH++---+ Yesod/Static.hs           | 121 ----------------------------------------------+ dist/package.conf.inplace |   3 +-+ 2 files changed, 2 insertions(+), 122 deletions(-)++diff --git a/Yesod/Static.hs b/Yesod/Static.hs+index e8ca09f..193b1f0 100644+--- a/Yesod/Static.hs++++ b/Yesod/Static.hs+@@ -1,5 +1,3 @@+-{-# LANGUAGE QuasiQuotes #-}+-{-# LANGUAGE TemplateHaskell #-}+ {-# LANGUAGE TypeFamilies #-}+ {-# LANGUAGE CPP #-}+ {-# LANGUAGE FlexibleInstances #-}+@@ -34,11 +32,6 @@ module Yesod.Static+       -- * Smart constructor+     , static+     , staticDevel+-    , embed+-      -- * Template Haskell helpers+-    , staticFiles+-    , staticFilesList+-    , publicFiles+       -- * Hashing+     , base64md5+ #ifdef TEST_EXPORT+@@ -50,7 +43,6 @@ import Prelude hiding (FilePath)+ import qualified Prelude+ import System.Directory+ import Control.Monad+-import Data.FileEmbed (embedDir)+ + import Yesod.Core hiding (lift)+ +@@ -111,18 +103,6 @@ staticDevel dir = do+     hashLookup <- cachedETagLookupDevel dir+     return $ Static $ webAppSettingsWithLookup (F.decodeString dir) hashLookup+ +--- | Produce a 'Static' based on embedding all of the static+--- files' contents in the executable at compile time.+--- Nota Bene: if you replace the scaffolded 'static' call in Settings/StaticFiles.hs+--- you will need to change the scaffolded addStaticContent.  Otherwise, some of your+--- assets will be 404'ed.  This is because by default yesod will generate compile those+--- assets to @static/tmp@ which for 'static' is fine since they are served out of the +--- directory itself.  With embedded static, that will not work.  +--- You can easily change @addStaticContent@ to @\_ _ _ -> return Nothing@ as a workaround.+--- This will cause yesod to embed those assets into the generated HTML file itself.  +-embed :: Prelude.FilePath -> Q Exp+-embed fp = [|Static (embeddedSettings $(embedDir fp))|]+-+ instance RenderRoute Static where+     -- | A route on the static subsite (see also 'staticFiles').+     --+@@ -167,59 +147,6 @@ getFileListPieces = flip go id+         dirs' <- mapM (\f -> go (fullPath f) (front . (:) f)) dirs+         return $ concat $ files' : dirs'+ +--- | Template Haskell function that automatically creates routes+--- for all of your static files.+---+--- For example, if you used+---+--- > staticFiles "static/"+---+--- and you had files @\"static\/style.css\"@ and+--- @\"static\/js\/script.js\"@, then the following top-level+--- definitions would be created:+---+--- > style_css    = StaticRoute ["style.css"]    []+--- > js_script_js = StaticRoute ["js/script.js"] []+---+--- Note that dots (@.@), dashes (@-@) and slashes (@\/@) are+--- replaced by underscores (@\_@) to create valid Haskell+--- identifiers.+-staticFiles :: Prelude.FilePath -> Q [Dec]+-staticFiles dir = mkStaticFiles dir+-+--- | Same as 'staticFiles', but takes an explicit list of files+--- to create identifiers for. The files path given are relative+--- to the static folder. For example, to create routes for the+--- files @\"static\/js\/jquery.js\"@ and+--- @\"static\/css\/normalize.css\"@, you would use:+---+--- > staticFilesList \"static\" [\"js\/jquery.js\", \"css\/normalize.css\"]+---+--- This can be useful when you have a very large number of static+--- files, but only need to refer to a few of them from Haskell.+-staticFilesList :: Prelude.FilePath -> [Prelude.FilePath] -> Q [Dec]+-staticFilesList dir fs =+-    mkStaticFilesList dir (map split fs) "StaticRoute" True+-  where+-    split :: Prelude.FilePath -> [String]+-    split [] = []+-    split x =+-        let (a, b) = break (== '/') x+-         in a : split (drop 1 b)+-+--- | Same as 'staticFiles', but doesn't append an ETag to the+--- query string.+---+--- Using 'publicFiles' will speed up the compilation, since there+--- won't be any need for hashing files during compile-time.+--- However, since the ETag ceases to be part of the URL, the+--- 'Static' subsite won't be able to set the expire date too far+--- on the future.  Browsers still will be able to cache the+--- contents, however they'll need send a request to the server to+--- see if their copy is up-to-date.+-publicFiles :: Prelude.FilePath -> Q [Dec]+-publicFiles dir = mkStaticFiles' dir "StaticRoute" False+-+ + mkHashMap :: Prelude.FilePath -> IO (M.Map F.FilePath S8.ByteString)+ mkHashMap dir = do+@@ -262,54 +189,6 @@ cachedETagLookup dir = do+     etags <- mkHashMap dir+     return $ (\f -> return $ M.lookup f etags)+ +-mkStaticFiles :: Prelude.FilePath -> Q [Dec]+-mkStaticFiles fp = mkStaticFiles' fp "StaticRoute" True+-+-mkStaticFiles' :: Prelude.FilePath -- ^ static directory+-               -> String   -- ^ route constructor "StaticRoute"+-               -> Bool     -- ^ append checksum query parameter+-               -> Q [Dec]+-mkStaticFiles' fp routeConName makeHash = do+-    fs <- qRunIO $ getFileListPieces fp+-    mkStaticFilesList fp fs routeConName makeHash+-+-mkStaticFilesList+-    :: Prelude.FilePath -- ^ static directory+-    -> [[String]] -- ^ list of files to create identifiers for+-    -> String   -- ^ route constructor "StaticRoute"+-    -> Bool     -- ^ append checksum query parameter+-    -> Q [Dec]+-mkStaticFilesList fp fs routeConName makeHash = do+-    concat `fmap` mapM mkRoute fs+-  where+-    replace' c+-        | 'A' <= c && c <= 'Z' = c+-        | 'a' <= c && c <= 'z' = c+-        | '0' <= c && c <= '9' = c+-        | otherwise = '_'+-    mkRoute f = do+-        let name' = intercalate "_" $ map (map replace') f+-            routeName = mkName $+-                case () of+-                    ()+-                        | null name' -> error "null-named file"+-                        | isDigit (head name') -> '_' : name'+-                        | isLower (head name') -> name'+-                        | otherwise -> '_' : name'+-        f' <- [|map pack $(lift f)|]+-        let route = mkName routeConName+-        pack' <- [|pack|]+-        qs <- if makeHash+-                    then do hash <- qRunIO $ base64md5File $ pathFromRawPieces fp f+-                            [|[(pack "etag", pack $(lift hash))]|]+-                    else return $ ListE []+-        return+-            [ SigD routeName $ ConT route+-            , FunD routeName+-                [ Clause [] (NormalB $ (ConE route) `AppE` f' `AppE` qs) []+-                ]+-            ]+-+ base64md5File :: Prelude.FilePath -> IO String+ base64md5File = fmap (base64 . encode) . hashFile+     where encode d = Data.Serialize.encode (d :: MD5)+diff --git a/dist/package.conf.inplace b/dist/package.conf.inplace+index 0637a08..eeff311 100644+--- a/dist/package.conf.inplace++++ b/dist/package.conf.inplace+@@ -1 +1,2 @@+-[]+\ No newline at end of file++[InstalledPackageInfo {installedPackageId = InstalledPackageId "yesod-static-1.1.2-inplace", sourcePackageId = PackageIdentifier {pkgName = PackageName "yesod-static", pkgVersion = Version {versionBranch = [1,1,2], versionTags = []}}, license = MIT, copyright = "", maintainer = "Michael Snoyman <michael@snoyman.com>, Greg Weber <greg@gregweber.info>", author = "Michael Snoyman <michael@snoyman.com>", stability = "Stable", homepage = "http://www.yesodweb.com/", pkgUrl = "", synopsis = "Static file serving subsite for Yesod Web Framework.", description = "Static file serving subsite for Yesod Web Framework.", category = "Web, Yesod", exposed = True, exposedModules = ["Yesod.Static"], hiddenModules = [], trusted = False, importDirs = ["/home/joey/yesod-static-1.1.2/dist/build"], libraryDirs = ["/home/joey/yesod-static-1.1.2/dist/build"], hsLibraries = ["HSyesod-static-1.1.2"], extraLibraries = [], extraGHCiLibraries = [], includeDirs = [], includes = [], depends = [InstalledPackageId "base-4.7.0.0-460992ac16ead97d88c73f4125e796d4",InstalledPackageId "base64-bytestring-1.0.0.1-8f54bb73ec493a5130061ebca542c11e",InstalledPackageId "bytestring-0.10.3.0-9c590669208a87636c23a3d3510a31ff",InstalledPackageId "cereal-0.3.5.2-f30c5cc09d1cc15977a64fe292c53513",InstalledPackageId "conduit-0.5.6-3168abc5ff00ded4bbc15f5915ad8633",InstalledPackageId "containers-0.5.0.0-eaa71ab98116fcd2d322913214739de5",InstalledPackageId "crypto-conduit-0.4.3-7a2968522a5c4748ce5988a2a466061e",InstalledPackageId "cryptohash-0.8.3-0aac68aa3a568ebeb89a354c921feb58",InstalledPackageId "directory-1.2.0.1-ca44c33c2fac281048d0dd7cd29e86c3",InstalledPackageId "file-embed-0.0.4.7-70a8411da82b83a0bbea9ecb291922ca",InstalledPackageId "http-types-0.7.3.0.1-09ea63b109c64a8370a96ee561c3ab2a",InstalledPackageId "old-time-1.1.0.1-9c370bbecb794b4c05408eb17a0038f1",InstalledPackageId "system-filepath-0.4.7-9506cbec38ccb0e49fd3a1dcce66306e",InstalledPackageId "template-haskell-2.9.0.0-60ba2293ffcafe171e54a808fdce5a7c",InstalledPackageId "text-0.11.2.3-948bb4afd264a1a5c0cca04031b4151c",InstalledPackageId "transformers-0.3.0.0-bae5adc5a648f25bafc73de9dc6a08a0",InstalledPackageId "unix-compat-0.4.1.0-0019b5bc860083c9a153099b086619ed",InstalledPackageId "wai-1.3.0.2-0f2b7cd8b8b0d8a776528af2b9f1f4f9",InstalledPackageId "wai-app-static-1.3.1-a32981caae981238524cee9823ccc666",InstalledPackageId "yesod-core-1.1.8-c0a15bfed9cb8f978bdf71ddd343ea18"], hugsOptions = [], ccOptions = [], ldOptions = [], frameworkDirs = [], frameworks = [], haddockInterfaces = ["/home/joey/yesod-static-1.1.2/dist/doc/html/yesod-static/yesod-static.haddock"], haddockHTMLs = ["/home/joey/yesod-static-1.1.2/dist/doc/html/yesod-static"]}++]+\ No newline at end of file+-- +1.8.2.rc3+
+ standalone/android/start view

binary file changed (absent → 6850 bytes)

+ static/activityicon.gif view

binary file changed (absent → 529 bytes)

+ static/syncicon.gif view

binary file changed (absent → 847 bytes)

templates/configurators/ssh/error.hamlet view
@@ -4,7 +4,9 @@   <p>     Something went wrong setting up the repository on the remote server.   <p>-    Transcript: #{msg}+    Transcript:+    <pre>+      #{msg}   <p>     <a .btn .btn-primary href="#">      Retry
templates/dashboard/transfers.hamlet view
@@ -36,9 +36,10 @@             $else               ^{actionButton (StartTransferR transfer) Nothing (Just "continue") "btn" "icon-play"}             ^{actionButton (CancelTransferR transfer) Nothing (Just "cancel") "btn" "icon-remove"}+  $if scanrunning+    <img src="@{StaticR activityicon_gif}" alt=""> #+    Scanning for files to transfer   $else-    $if scanrunning-      <i .icon-refresh></i> Scanning for files to transfer-    $else+    $if (not transfersrunning)       <i>         (No file transfers running)