allow configuring the preferreddir

Assistant/WebApp/Configurators/Edit.hs

@@ -45,26 +45,32 @@ data RepoConfig = RepoConfig
 	{ repoName :: Text
 	, repoDescription :: Maybe Text
 	, repoGroup :: RepoGroup
+	, repoAssociatedDirectory :: Maybe Text
 	, repoSyncable :: Bool
 	}
 	deriving (Show)
 
 getRepoConfig :: UUID -> Maybe Remote -> Annex RepoConfig
-getRepoConfig uuid mremote = RepoConfig
-	<$> pure (T.pack $ maybe "here" Remote.name mremote)
-	<*> (maybe Nothing (Just . T.pack) . M.lookup uuid <$> uuidMap)
-	<*> getrepogroup
-	<*> getsyncing
-  where
-	getrepogroup = do
-		groups <- lookupGroups uuid
-		return $ 
-			maybe (RepoGroupCustom $ unwords $ S.toList groups) RepoGroupStandard
-				(getStandardGroup groups)
-	getsyncing = case mremote of
+getRepoConfig uuid mremote = do
+	groups <- lookupGroups uuid
+	remoteconfig <- M.lookup uuid <$> readRemoteLog
+	let (repogroup, associateddirectory) = case getStandardGroup groups of
+		Nothing -> (RepoGroupCustom $ unwords $ S.toList groups, Nothing)
+		Just g -> (RepoGroupStandard g, associatedDirectory remoteconfig g)
+	
+	description <- maybe Nothing (Just . T.pack) . M.lookup uuid <$> uuidMap
+
+	syncable <- case mremote of
 		Just r -> return $ remoteAnnexSync $ Remote.gitconfig r
 		Nothing -> annexAutoCommit <$> Annex.getGitConfig
 
+	return $ RepoConfig
+		(T.pack $ maybe "here" Remote.name mremote)
+		description
+		repogroup
+		(T.pack <$> associateddirectory)
+		syncable
+		
 setRepoConfig :: UUID -> Maybe Remote -> RepoConfig -> RepoConfig -> Handler ()
 setRepoConfig uuid mremote oldc newc = do
 	when descriptionChanged $ liftAnnex $ do
@@ -91,6 +97,17 @@ setRepoConfig uuid mremote oldc newc = do
 				]
 			void $ Remote.remoteListRefresh
 		liftAssistant updateSyncRemotes
+	when associatedDirectoryChanged $ case repoAssociatedDirectory newc of
+		Nothing -> noop
+		Just t
+			| T.null t -> noop
+			| otherwise -> liftAnnex $ do
+				let dir = takeBaseName $ T.unpack t
+				m <- readRemoteLog
+				case M.lookup uuid m of
+					Nothing -> noop
+					Just remoteconfig -> configSet uuid $
+						M.insert "preferreddir" dir remoteconfig
 	when groupChanged $ do
 		liftAnnex $ case repoGroup newc of
 			RepoGroupStandard g -> setStandardGroup uuid g
@@ -108,22 +125,24 @@ setRepoConfig uuid mremote oldc newc = do
 		changeSyncable mremote (repoSyncable newc)
   where
   	syncableChanged = repoSyncable oldc /= repoSyncable newc
+	associatedDirectoryChanged = repoAssociatedDirectory oldc /= repoAssociatedDirectory 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 -> Maybe Remote.RemoteConfig -> AForm WebApp WebApp RepoConfig
-editRepositoryAForm def remoteconfig = RepoConfig
+editRepositoryAForm :: RepoConfig -> AForm WebApp WebApp RepoConfig
+editRepositoryAForm def = RepoConfig
 	<$> areq textField "Name" (Just $ repoName def)
 	<*> aopt textField "Description" (Just $ repoDescription def)
 	<*> areq (selectFieldList groups `withNote` help) "Repository group" (Just $ repoGroup def)
+	<*> associateddirectory
 	<*> areq checkBoxField "Syncing enabled" (Just $ repoSyncable def)
   where
 	groups = customgroups ++ standardgroups
 	standardgroups :: [(Text, RepoGroup)]
-	standardgroups = map (\g -> (T.pack $ descStandardGroup remoteconfig g , RepoGroupStandard g))
+	standardgroups = map (\g -> (T.pack $ descStandardGroup g , RepoGroupStandard g))
 		[minBound :: StandardGroup .. maxBound :: StandardGroup]
 	customgroups :: [(Text, RepoGroup)]
 	customgroups = case repoGroup def of
@@ -131,6 +150,10 @@ editRepositoryAForm def remoteconfig = RepoConfig
 		_ -> []
 	help = [whamlet|<a href="@{RepoGroupR}">What's this?</a>|]
 
+	associateddirectory = case repoAssociatedDirectory def of
+		Nothing -> aopt dummyField "" Nothing
+		Just d -> aopt textField "Associated directory" (Just $ Just d)
+
 getEditRepositoryR :: UUID -> Handler RepHtml
 getEditRepositoryR = postEditRepositoryR
 
@@ -153,27 +176,28 @@ editForm :: Bool -> UUID -> Handler RepHtml
 editForm new uuid = page "Configure repository" (Just Configuration) $ do
 	mremote <- liftAnnex $ Remote.remoteFromUUID uuid
 	curr <- liftAnnex $ getRepoConfig uuid mremote
-	config <- M.lookup uuid <$> liftAnnex readRemoteLog
-	lift $ checkdirectories curr config
+	liftAnnex $ checkAssociatedDirectory curr mremote
 	((result, form), enctype) <- lift $
-		runFormPost $ renderBootstrap $ editRepositoryAForm curr config
+		runFormPost $ renderBootstrap $ editRepositoryAForm curr
 	case result of
 		FormSuccess input -> lift $ do
-			checkdirectories input config
 			setRepoConfig uuid mremote curr input
+			liftAnnex $ checkAssociatedDirectory input mremote
 			redirect DashboardR
 		_ -> do
 			let istransfer = repoGroup curr == RepoGroupStandard TransferGroup
-			let repoInfo = getRepoInfo mremote config
+			repoInfo <- getRepoInfo mremote . M.lookup uuid
+				<$> liftAnnex readRemoteLog
 			$(widgetFile "configurators/editrepository")
-  where
-	{- Makes any special directory associated with the repository.
-	 - This is done both when displaying the form, as well as after
-	 - it's posted, because the user may not post the form,
-	 - but may see that the repo is set up to use the directory. -}
-	checkdirectories cfg repoconfig = case repoGroup cfg of
-		RepoGroupStandard gr -> case specialDirectory repoconfig gr of
-			Just d -> liftAnnex $ inRepo $ \g ->
+
+{- Makes any directory associated with the repository. -}
+checkAssociatedDirectory :: RepoConfig -> Maybe Remote -> Annex ()
+checkAssociatedDirectory _ Nothing = noop
+checkAssociatedDirectory cfg (Just r) = do
+	repoconfig <- M.lookup (Remote.uuid r) <$> readRemoteLog
+	case repoGroup cfg of
+		RepoGroupStandard gr -> case associatedDirectory repoconfig gr of
+			Just d -> inRepo $ \g ->
 				createDirectoryIfMissing True $
 					Git.repoPath g </> d
 			Nothing -> noop

Assistant/WebApp/Configurators/IA.hs

@@ -61,10 +61,10 @@ formatMediaType MediaOmitted = ""
 collectionMediaType :: MediaType -> Maybe String
 collectionMediaType MediaText = Just "opensource"
 collectionMediaType MediaImages = Just "opensource" -- not ideal
-collectionMediaType MediaSoftware = Just "opensource -- not ideal
+collectionMediaType MediaSoftware = Just "opensource" -- not ideal
 collectionMediaType MediaVideo = Just "opensource_movies"
 collectionMediaType MediaAudio = Just "opensource_audio"
-collectionMediaType MediaOmitted = Jusr "opensource"
+collectionMediaType MediaOmitted = Just "opensource"
 
 {- Format a MediaType for user display. -}
 showMediaType :: MediaType -> String
@@ -182,10 +182,10 @@ getRepoInfo c = do
 	exists <- liftIO $ catchDefaultIO False $ fst <$> Url.exists url []
 	[whamlet|
 <a href="#{url}">
-  Internet Archive page
+  Internet Archive item
 $if (not exists)
   <p>
-    The page will only appear once some files #
+    The page will only be available once some files #
     have been uploaded, and the Internet Archive has processed them.
 |]
   where

Assistant/WebApp/Form.hs

@@ -39,6 +39,13 @@ passwordField = F.passwordField
 |]
 	}
 
+{- Useful in an AForm when sometimes a field is not used. -}
+dummyField :: RenderMessage master FormMessage => Field sub master Text
+dummyField = Field
+	{ fieldView = \_theId _name _attrs _val _isReq -> return ()
+	, fieldParse = const $ return $ Right Nothing
+	}
+
 {- Makes a note widget be displayed after a field. -}
 withNote :: Field sub master v -> GWidget sub master () -> Field sub master v
 withNote field note = field { fieldView = newview }

Types/StandardGroups.hs

@@ -50,25 +50,25 @@ toStandardGroup "public" = Just PublicGroup
 toStandardGroup "unwanted" = Just UnwantedGroup
 toStandardGroup _ = Nothing
 
-descStandardGroup :: Maybe RemoteConfig -> StandardGroup -> String
-descStandardGroup _ ClientGroup = "client: a repository on your computer"
-descStandardGroup _ TransferGroup = "transfer: distributes files to clients"
-descStandardGroup _ BackupGroup = "full backup: backs up all files"
-descStandardGroup _ IncrementalBackupGroup = "incremental backup: backs up files not backed up elsewhere"
-descStandardGroup _ SmallArchiveGroup = "small archive: archives files located in \"archive\" directories"
-descStandardGroup _ FullArchiveGroup = "full archive: archives all files not archived elsewhere"
-descStandardGroup _ SourceGroup = "file source: moves files on to other repositories"
-descStandardGroup _ ManualGroup = "manual mode: only stores files you manually choose"
-descStandardGroup _ UnwantedGroup = "unwanted: remove content from this repository"
-descStandardGroup c PublicGroup = "public: only stores files located in \"" ++ fromJust (specialDirectory c PublicGroup) ++ "\" directories"
+descStandardGroup :: StandardGroup -> String
+descStandardGroup ClientGroup = "client: a repository on your computer"
+descStandardGroup TransferGroup = "transfer: distributes files to clients"
+descStandardGroup BackupGroup = "full backup: backs up all files"
+descStandardGroup IncrementalBackupGroup = "incremental backup: backs up files not backed up elsewhere"
+descStandardGroup SmallArchiveGroup = "small archive: archives files located in \"archive\" directories"
+descStandardGroup FullArchiveGroup = "full archive: archives all files not archived elsewhere"
+descStandardGroup SourceGroup = "file source: moves files on to other repositories"
+descStandardGroup ManualGroup = "manual mode: only stores files you manually choose"
+descStandardGroup UnwantedGroup = "unwanted: remove content from this repository"
+descStandardGroup PublicGroup = "public: publishes files located in an associated directory"
 
-specialDirectory :: Maybe RemoteConfig -> StandardGroup -> Maybe FilePath
-specialDirectory _ SmallArchiveGroup = Just "archive"
-specialDirectory _ FullArchiveGroup = Just "archive"
-specialDirectory (Just c) PublicGroup = Just $
+associatedDirectory :: Maybe RemoteConfig -> StandardGroup -> Maybe FilePath
+associatedDirectory _ SmallArchiveGroup = Just "archive"
+associatedDirectory _ FullArchiveGroup = Just "archive"
+associatedDirectory (Just c) PublicGroup = Just $
 	fromMaybe "public" $ M.lookup "preferreddir" c
-specialDirectory Nothing PublicGroup = Just "public"
-specialDirectory _ _ = Nothing
+associatedDirectory Nothing PublicGroup = Just "public"
+associatedDirectory _ _ = Nothing
 
 {- See doc/preferred_content.mdwn for explanations of these expressions. -}
 preferredContent :: StandardGroup -> String

templates/documentation/repogroup.hamlet

@@ -50,7 +50,7 @@
     If you configure a repository that can be viwed by the public, #
     but you don't want all your files to show up there, you can #
     configure it to be a <b>public repository</b>. Then only files #
-    located in a particular directory will be sent to it.
+    located in a directory you choose will be sent to it.
   <p>
     Finally, repositories can be configured to be in <b>manual mode</b>. This #
     prevents content being automatically synced to the repository, but #