allow configuring the preferreddir
This commit is contained in:
parent
867cba52a0
commit
8603109294
5 changed files with 81 additions and 50 deletions
|
@ -45,26 +45,32 @@ data RepoConfig = RepoConfig
|
||||||
{ repoName :: Text
|
{ repoName :: Text
|
||||||
, repoDescription :: Maybe Text
|
, repoDescription :: Maybe Text
|
||||||
, repoGroup :: RepoGroup
|
, repoGroup :: RepoGroup
|
||||||
|
, repoAssociatedDirectory :: Maybe Text
|
||||||
, repoSyncable :: Bool
|
, repoSyncable :: Bool
|
||||||
}
|
}
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
|
||||||
getRepoConfig :: UUID -> Maybe Remote -> Annex RepoConfig
|
getRepoConfig :: UUID -> Maybe Remote -> Annex RepoConfig
|
||||||
getRepoConfig uuid mremote = RepoConfig
|
getRepoConfig uuid mremote = do
|
||||||
<$> pure (T.pack $ maybe "here" Remote.name mremote)
|
groups <- lookupGroups uuid
|
||||||
<*> (maybe Nothing (Just . T.pack) . M.lookup uuid <$> uuidMap)
|
remoteconfig <- M.lookup uuid <$> readRemoteLog
|
||||||
<*> getrepogroup
|
let (repogroup, associateddirectory) = case getStandardGroup groups of
|
||||||
<*> getsyncing
|
Nothing -> (RepoGroupCustom $ unwords $ S.toList groups, Nothing)
|
||||||
where
|
Just g -> (RepoGroupStandard g, associatedDirectory remoteconfig g)
|
||||||
getrepogroup = do
|
|
||||||
groups <- lookupGroups uuid
|
description <- maybe Nothing (Just . T.pack) . M.lookup uuid <$> uuidMap
|
||||||
return $
|
|
||||||
maybe (RepoGroupCustom $ unwords $ S.toList groups) RepoGroupStandard
|
syncable <- case mremote of
|
||||||
(getStandardGroup groups)
|
|
||||||
getsyncing = case mremote of
|
|
||||||
Just r -> return $ remoteAnnexSync $ Remote.gitconfig r
|
Just r -> return $ remoteAnnexSync $ Remote.gitconfig r
|
||||||
Nothing -> annexAutoCommit <$> Annex.getGitConfig
|
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 -> Maybe Remote -> RepoConfig -> RepoConfig -> Handler ()
|
||||||
setRepoConfig uuid mremote oldc newc = do
|
setRepoConfig uuid mremote oldc newc = do
|
||||||
when descriptionChanged $ liftAnnex $ do
|
when descriptionChanged $ liftAnnex $ do
|
||||||
|
@ -91,6 +97,17 @@ setRepoConfig uuid mremote oldc newc = do
|
||||||
]
|
]
|
||||||
void $ Remote.remoteListRefresh
|
void $ Remote.remoteListRefresh
|
||||||
liftAssistant updateSyncRemotes
|
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
|
when groupChanged $ do
|
||||||
liftAnnex $ case repoGroup newc of
|
liftAnnex $ case repoGroup newc of
|
||||||
RepoGroupStandard g -> setStandardGroup uuid g
|
RepoGroupStandard g -> setStandardGroup uuid g
|
||||||
|
@ -108,22 +125,24 @@ setRepoConfig uuid mremote oldc newc = do
|
||||||
changeSyncable mremote (repoSyncable newc)
|
changeSyncable mremote (repoSyncable newc)
|
||||||
where
|
where
|
||||||
syncableChanged = repoSyncable oldc /= repoSyncable newc
|
syncableChanged = repoSyncable oldc /= repoSyncable newc
|
||||||
|
associatedDirectoryChanged = repoAssociatedDirectory oldc /= repoAssociatedDirectory newc
|
||||||
groupChanged = repoGroup oldc /= repoGroup newc
|
groupChanged = repoGroup oldc /= repoGroup newc
|
||||||
nameChanged = isJust mremote && legalName oldc /= legalName newc
|
nameChanged = isJust mremote && legalName oldc /= legalName newc
|
||||||
descriptionChanged = repoDescription oldc /= repoDescription newc
|
descriptionChanged = repoDescription oldc /= repoDescription newc
|
||||||
|
|
||||||
legalName = makeLegalName . T.unpack . repoName
|
legalName = makeLegalName . T.unpack . repoName
|
||||||
|
|
||||||
editRepositoryAForm :: RepoConfig -> Maybe Remote.RemoteConfig -> AForm WebApp WebApp RepoConfig
|
editRepositoryAForm :: RepoConfig -> AForm WebApp WebApp RepoConfig
|
||||||
editRepositoryAForm def remoteconfig = RepoConfig
|
editRepositoryAForm def = RepoConfig
|
||||||
<$> areq textField "Name" (Just $ repoName def)
|
<$> areq textField "Name" (Just $ repoName def)
|
||||||
<*> aopt textField "Description" (Just $ repoDescription def)
|
<*> aopt textField "Description" (Just $ repoDescription def)
|
||||||
<*> areq (selectFieldList groups `withNote` help) "Repository group" (Just $ repoGroup def)
|
<*> areq (selectFieldList groups `withNote` help) "Repository group" (Just $ repoGroup def)
|
||||||
|
<*> associateddirectory
|
||||||
<*> areq checkBoxField "Syncing enabled" (Just $ repoSyncable def)
|
<*> areq checkBoxField "Syncing enabled" (Just $ repoSyncable def)
|
||||||
where
|
where
|
||||||
groups = customgroups ++ standardgroups
|
groups = customgroups ++ standardgroups
|
||||||
standardgroups :: [(Text, RepoGroup)]
|
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]
|
[minBound :: StandardGroup .. maxBound :: StandardGroup]
|
||||||
customgroups :: [(Text, RepoGroup)]
|
customgroups :: [(Text, RepoGroup)]
|
||||||
customgroups = case repoGroup def of
|
customgroups = case repoGroup def of
|
||||||
|
@ -131,6 +150,10 @@ editRepositoryAForm def remoteconfig = RepoConfig
|
||||||
_ -> []
|
_ -> []
|
||||||
help = [whamlet|<a href="@{RepoGroupR}">What's this?</a>|]
|
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 :: UUID -> Handler RepHtml
|
||||||
getEditRepositoryR = postEditRepositoryR
|
getEditRepositoryR = postEditRepositoryR
|
||||||
|
|
||||||
|
@ -153,27 +176,28 @@ editForm :: Bool -> UUID -> Handler RepHtml
|
||||||
editForm new uuid = page "Configure repository" (Just Configuration) $ do
|
editForm new uuid = page "Configure repository" (Just Configuration) $ do
|
||||||
mremote <- liftAnnex $ Remote.remoteFromUUID uuid
|
mremote <- liftAnnex $ Remote.remoteFromUUID uuid
|
||||||
curr <- liftAnnex $ getRepoConfig uuid mremote
|
curr <- liftAnnex $ getRepoConfig uuid mremote
|
||||||
config <- M.lookup uuid <$> liftAnnex readRemoteLog
|
liftAnnex $ checkAssociatedDirectory curr mremote
|
||||||
lift $ checkdirectories curr config
|
|
||||||
((result, form), enctype) <- lift $
|
((result, form), enctype) <- lift $
|
||||||
runFormPost $ renderBootstrap $ editRepositoryAForm curr config
|
runFormPost $ renderBootstrap $ editRepositoryAForm curr
|
||||||
case result of
|
case result of
|
||||||
FormSuccess input -> lift $ do
|
FormSuccess input -> lift $ do
|
||||||
checkdirectories input config
|
|
||||||
setRepoConfig uuid mremote curr input
|
setRepoConfig uuid mremote curr input
|
||||||
|
liftAnnex $ checkAssociatedDirectory input mremote
|
||||||
redirect DashboardR
|
redirect DashboardR
|
||||||
_ -> do
|
_ -> do
|
||||||
let istransfer = repoGroup curr == RepoGroupStandard TransferGroup
|
let istransfer = repoGroup curr == RepoGroupStandard TransferGroup
|
||||||
let repoInfo = getRepoInfo mremote config
|
repoInfo <- getRepoInfo mremote . M.lookup uuid
|
||||||
|
<$> liftAnnex readRemoteLog
|
||||||
$(widgetFile "configurators/editrepository")
|
$(widgetFile "configurators/editrepository")
|
||||||
where
|
|
||||||
{- Makes any special directory associated with the repository.
|
{- Makes any directory associated with the repository. -}
|
||||||
- This is done both when displaying the form, as well as after
|
checkAssociatedDirectory :: RepoConfig -> Maybe Remote -> Annex ()
|
||||||
- it's posted, because the user may not post the form,
|
checkAssociatedDirectory _ Nothing = noop
|
||||||
- but may see that the repo is set up to use the directory. -}
|
checkAssociatedDirectory cfg (Just r) = do
|
||||||
checkdirectories cfg repoconfig = case repoGroup cfg of
|
repoconfig <- M.lookup (Remote.uuid r) <$> readRemoteLog
|
||||||
RepoGroupStandard gr -> case specialDirectory repoconfig gr of
|
case repoGroup cfg of
|
||||||
Just d -> liftAnnex $ inRepo $ \g ->
|
RepoGroupStandard gr -> case associatedDirectory repoconfig gr of
|
||||||
|
Just d -> inRepo $ \g ->
|
||||||
createDirectoryIfMissing True $
|
createDirectoryIfMissing True $
|
||||||
Git.repoPath g </> d
|
Git.repoPath g </> d
|
||||||
Nothing -> noop
|
Nothing -> noop
|
||||||
|
|
|
@ -61,10 +61,10 @@ formatMediaType MediaOmitted = ""
|
||||||
collectionMediaType :: MediaType -> Maybe String
|
collectionMediaType :: MediaType -> Maybe String
|
||||||
collectionMediaType MediaText = Just "opensource"
|
collectionMediaType MediaText = Just "opensource"
|
||||||
collectionMediaType MediaImages = Just "opensource" -- not ideal
|
collectionMediaType MediaImages = Just "opensource" -- not ideal
|
||||||
collectionMediaType MediaSoftware = Just "opensource -- not ideal
|
collectionMediaType MediaSoftware = Just "opensource" -- not ideal
|
||||||
collectionMediaType MediaVideo = Just "opensource_movies"
|
collectionMediaType MediaVideo = Just "opensource_movies"
|
||||||
collectionMediaType MediaAudio = Just "opensource_audio"
|
collectionMediaType MediaAudio = Just "opensource_audio"
|
||||||
collectionMediaType MediaOmitted = Jusr "opensource"
|
collectionMediaType MediaOmitted = Just "opensource"
|
||||||
|
|
||||||
{- Format a MediaType for user display. -}
|
{- Format a MediaType for user display. -}
|
||||||
showMediaType :: MediaType -> String
|
showMediaType :: MediaType -> String
|
||||||
|
@ -182,10 +182,10 @@ getRepoInfo c = do
|
||||||
exists <- liftIO $ catchDefaultIO False $ fst <$> Url.exists url []
|
exists <- liftIO $ catchDefaultIO False $ fst <$> Url.exists url []
|
||||||
[whamlet|
|
[whamlet|
|
||||||
<a href="#{url}">
|
<a href="#{url}">
|
||||||
Internet Archive page
|
Internet Archive item
|
||||||
$if (not exists)
|
$if (not exists)
|
||||||
<p>
|
<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.
|
have been uploaded, and the Internet Archive has processed them.
|
||||||
|]
|
|]
|
||||||
where
|
where
|
||||||
|
|
|
@ -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. -}
|
{- Makes a note widget be displayed after a field. -}
|
||||||
withNote :: Field sub master v -> GWidget sub master () -> Field sub master v
|
withNote :: Field sub master v -> GWidget sub master () -> Field sub master v
|
||||||
withNote field note = field { fieldView = newview }
|
withNote field note = field { fieldView = newview }
|
||||||
|
|
|
@ -50,25 +50,25 @@ toStandardGroup "public" = Just PublicGroup
|
||||||
toStandardGroup "unwanted" = Just UnwantedGroup
|
toStandardGroup "unwanted" = Just UnwantedGroup
|
||||||
toStandardGroup _ = Nothing
|
toStandardGroup _ = Nothing
|
||||||
|
|
||||||
descStandardGroup :: Maybe RemoteConfig -> StandardGroup -> String
|
descStandardGroup :: StandardGroup -> String
|
||||||
descStandardGroup _ ClientGroup = "client: a repository on your computer"
|
descStandardGroup ClientGroup = "client: a repository on your computer"
|
||||||
descStandardGroup _ TransferGroup = "transfer: distributes files to clients"
|
descStandardGroup TransferGroup = "transfer: distributes files to clients"
|
||||||
descStandardGroup _ BackupGroup = "full backup: backs up all files"
|
descStandardGroup BackupGroup = "full backup: backs up all files"
|
||||||
descStandardGroup _ IncrementalBackupGroup = "incremental backup: backs up files not backed up elsewhere"
|
descStandardGroup IncrementalBackupGroup = "incremental backup: backs up files not backed up elsewhere"
|
||||||
descStandardGroup _ SmallArchiveGroup = "small archive: archives files located in \"archive\" directories"
|
descStandardGroup SmallArchiveGroup = "small archive: archives files located in \"archive\" directories"
|
||||||
descStandardGroup _ FullArchiveGroup = "full archive: archives all files not archived elsewhere"
|
descStandardGroup FullArchiveGroup = "full archive: archives all files not archived elsewhere"
|
||||||
descStandardGroup _ SourceGroup = "file source: moves files on to other repositories"
|
descStandardGroup SourceGroup = "file source: moves files on to other repositories"
|
||||||
descStandardGroup _ ManualGroup = "manual mode: only stores files you manually choose"
|
descStandardGroup ManualGroup = "manual mode: only stores files you manually choose"
|
||||||
descStandardGroup _ UnwantedGroup = "unwanted: remove content from this repository"
|
descStandardGroup UnwantedGroup = "unwanted: remove content from this repository"
|
||||||
descStandardGroup c PublicGroup = "public: only stores files located in \"" ++ fromJust (specialDirectory c PublicGroup) ++ "\" directories"
|
descStandardGroup PublicGroup = "public: publishes files located in an associated directory"
|
||||||
|
|
||||||
specialDirectory :: Maybe RemoteConfig -> StandardGroup -> Maybe FilePath
|
associatedDirectory :: Maybe RemoteConfig -> StandardGroup -> Maybe FilePath
|
||||||
specialDirectory _ SmallArchiveGroup = Just "archive"
|
associatedDirectory _ SmallArchiveGroup = Just "archive"
|
||||||
specialDirectory _ FullArchiveGroup = Just "archive"
|
associatedDirectory _ FullArchiveGroup = Just "archive"
|
||||||
specialDirectory (Just c) PublicGroup = Just $
|
associatedDirectory (Just c) PublicGroup = Just $
|
||||||
fromMaybe "public" $ M.lookup "preferreddir" c
|
fromMaybe "public" $ M.lookup "preferreddir" c
|
||||||
specialDirectory Nothing PublicGroup = Just "public"
|
associatedDirectory Nothing PublicGroup = Just "public"
|
||||||
specialDirectory _ _ = Nothing
|
associatedDirectory _ _ = Nothing
|
||||||
|
|
||||||
{- See doc/preferred_content.mdwn for explanations of these expressions. -}
|
{- See doc/preferred_content.mdwn for explanations of these expressions. -}
|
||||||
preferredContent :: StandardGroup -> String
|
preferredContent :: StandardGroup -> String
|
||||||
|
|
|
@ -50,7 +50,7 @@
|
||||||
If you configure a repository that can be viwed by the public, #
|
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 #
|
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 #
|
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>
|
<p>
|
||||||
Finally, repositories can be configured to be in <b>manual mode</b>. This #
|
Finally, repositories can be configured to be in <b>manual mode</b>. This #
|
||||||
prevents content being automatically synced to the repository, but #
|
prevents content being automatically synced to the repository, but #
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue