type based git config handling
Now there's a Config type, that's extracted from the git config at startup. Note that laziness means that individual config values are only looked up and parsed on demand, and so we get implicit memoization for all of them. So this is not only prettier and more type safe, it optimises several places that didn't have explicit memoization before. As well as getting rid of the ugly explicit memoization code. Not yet done for annex.<remote>.* configuration settings.
This commit is contained in:
Joey Hess
parent
b62753c475
commit
7f7c31df1c
23 changed files with 151 additions and 103 deletions
|
|
@ -32,6 +32,7 @@ import Types.KeySource
|
|||
import Config
|
||||
import Annex.Exception
|
||||
import Annex.Content
|
||||
import qualified Annex
|
||||
|
||||
import Data.Time.Clock
|
||||
import Data.Tuple.Utils
|
||||
|
|
@ -41,9 +42,9 @@ import Data.Either
|
|||
{- This thread makes git commits at appropriate times. -}
|
||||
commitThread :: NamedThread
|
||||
commitThread = NamedThread "Committer" $ do
|
||||
delayadd <- liftAnnex $ do
|
||||
v <- readish <$> getConfig (annexConfig "delayadd") ""
|
||||
maybe delayaddDefault (return . Just . Seconds) v
|
||||
delayadd <- liftAnnex $
|
||||
maybe delayaddDefault (return . Just . Seconds)
|
||||
=<< annexDelayAdd <$> Annex.getConfig
|
||||
runEvery (Seconds 1) <~> do
|
||||
-- We already waited one second as a simple rate limiter.
|
||||
-- Next, wait until at least one change is available for
|
||||
|
|
|
|||
|
|
@ -28,10 +28,10 @@ import Assistant.XMPP.Client
|
|||
import qualified Data.Map as M
|
||||
|
||||
{- The main configuration screen. -}
|
||||
getConfigR :: Handler RepHtml
|
||||
getConfigR = ifM (inFirstRun)
|
||||
getConfigurationR :: Handler RepHtml
|
||||
getConfigurationR = ifM (inFirstRun)
|
||||
( getFirstRepositoryR
|
||||
, page "Configuration" (Just Config) $ do
|
||||
, page "Configuration" (Just Configuration) $ do
|
||||
#ifdef WITH_XMPP
|
||||
xmppconfigured <- lift $ runAnnex False $ isJust <$> getXMPPCreds
|
||||
#else
|
||||
|
|
@ -62,7 +62,7 @@ makeCloudRepositories = $(widgetFile "configurators/repositories/cloud")
|
|||
|
||||
{- Lists known repositories, followed by options to add more. -}
|
||||
getRepositoriesR :: Handler RepHtml
|
||||
getRepositoriesR = page "Repositories" (Just Config) $ do
|
||||
getRepositoriesR = page "Repositories" (Just Configuration) $ do
|
||||
let repolist = repoListDisplay $ RepoSelector
|
||||
{ onlyCloud = False
|
||||
, onlyConfigured = False
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@ import qualified Data.Text as T
|
|||
import qualified Data.Map as M
|
||||
|
||||
awsConfigurator :: Widget -> Handler RepHtml
|
||||
awsConfigurator = page "Add an Amazon repository" (Just Config)
|
||||
awsConfigurator = page "Add an Amazon repository" (Just Configuration)
|
||||
|
||||
glacierConfigurator :: Widget -> Handler RepHtml
|
||||
glacierConfigurator a = do
|
||||
|
|
|
|||
|
|
@ -112,7 +112,7 @@ getEditNewCloudRepositoryR :: UUID -> Handler RepHtml
|
|||
getEditNewCloudRepositoryR uuid = xmppNeeded >> editForm True uuid
|
||||
|
||||
editForm :: Bool -> UUID -> Handler RepHtml
|
||||
editForm new uuid = page "Configure repository" (Just Config) $ do
|
||||
editForm new uuid = page "Configure repository" (Just Configuration) $ do
|
||||
(repo, mremote) <- lift $ runAnnex undefined $ Remote.repoFromUUID uuid
|
||||
curr <- lift $ runAnnex undefined $ getRepoConfig uuid repo mremote
|
||||
lift $ checkarchivedirectory curr
|
||||
|
|
|
|||
|
|
@ -29,7 +29,6 @@ import Annex.UUID
|
|||
import Types.StandardGroups
|
||||
import Logs.PreferredContent
|
||||
import Utility.UserInfo
|
||||
import Config
|
||||
|
||||
import qualified Data.Text as T
|
||||
import Data.Char
|
||||
|
|
@ -128,7 +127,7 @@ newRepositoryForm defpath msg = do
|
|||
|
||||
{- Making the first repository, when starting the webapp for the first time. -}
|
||||
getFirstRepositoryR :: Handler RepHtml
|
||||
getFirstRepositoryR = page "Getting started" (Just Config) $ do
|
||||
getFirstRepositoryR = page "Getting started" (Just Configuration) $ do
|
||||
path <- liftIO . defaultRepositoryPath =<< lift inFirstRun
|
||||
((res, form), enctype) <- lift $ runFormGet $ newRepositoryForm path
|
||||
case res of
|
||||
|
|
@ -138,7 +137,7 @@ getFirstRepositoryR = page "Getting started" (Just Config) $ do
|
|||
|
||||
{- Adding a new, separate repository. -}
|
||||
getNewRepositoryR :: Handler RepHtml
|
||||
getNewRepositoryR = page "Add another repository" (Just Config) $ do
|
||||
getNewRepositoryR = page "Add another repository" (Just Configuration) $ do
|
||||
home <- liftIO myHomeDir
|
||||
((res, form), enctype) <- lift $ runFormGet $ newRepositoryForm home
|
||||
case res of
|
||||
|
|
@ -175,7 +174,7 @@ selectDriveForm drives def = renderBootstrap $ RemovableDrive
|
|||
|
||||
{- Adding a removable drive. -}
|
||||
getAddDriveR :: Handler RepHtml
|
||||
getAddDriveR = page "Add a removable drive" (Just Config) $ do
|
||||
getAddDriveR = page "Add a removable drive" (Just Configuration) $ do
|
||||
removabledrives <- liftIO $ driveList
|
||||
writabledrives <- liftIO $
|
||||
filterM (canWrite . T.unpack . mountPoint) removabledrives
|
||||
|
|
@ -213,7 +212,7 @@ getAddDriveR = page "Add a removable drive" (Just Config) $ do
|
|||
addRemote $ makeGitRemote name dir
|
||||
|
||||
getEnableDirectoryR :: UUID -> Handler RepHtml
|
||||
getEnableDirectoryR uuid = page "Enable a repository" (Just Config) $ do
|
||||
getEnableDirectoryR uuid = page "Enable a repository" (Just Configuration) $ do
|
||||
description <- lift $ runAnnex "" $
|
||||
T.pack . concat <$> prettyListUUIDs [uuid]
|
||||
$(widgetFile "configurators/enabledirectory")
|
||||
|
|
|
|||
|
|
@ -286,7 +286,7 @@ sampleQuote = T.unwords
|
|||
#endif
|
||||
|
||||
pairPage :: Widget -> Handler RepHtml
|
||||
pairPage = page "Pairing" (Just Config)
|
||||
pairPage = page "Pairing" (Just Configuration)
|
||||
|
||||
noPairing :: Text -> Handler RepHtml
|
||||
noPairing pairingtype = pairPage $
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ import qualified Data.Map as M
|
|||
import Network.Socket
|
||||
|
||||
sshConfigurator :: Widget -> Handler RepHtml
|
||||
sshConfigurator = page "Add a remote server" (Just Config)
|
||||
sshConfigurator = page "Add a remote server" (Just Configuration)
|
||||
|
||||
data SshInput = SshInput
|
||||
{ inputHostname :: Maybe Text
|
||||
|
|
@ -288,7 +288,7 @@ getAddRsyncNetR = do
|
|||
((result, form), enctype) <- runFormGet $
|
||||
renderBootstrap $ sshInputAForm hostnamefield $
|
||||
SshInput Nothing Nothing Nothing 22
|
||||
let showform status = page "Add a Rsync.net repository" (Just Config) $
|
||||
let showform status = page "Add a Rsync.net repository" (Just Configuration) $
|
||||
$(widgetFile "configurators/addrsync.net")
|
||||
case result of
|
||||
FormSuccess sshinput
|
||||
|
|
|
|||
|
|
@ -26,10 +26,10 @@ import qualified Data.Text as T
|
|||
import qualified Data.Map as M
|
||||
|
||||
webDAVConfigurator :: Widget -> Handler RepHtml
|
||||
webDAVConfigurator = page "Add a WebDAV repository" (Just Config)
|
||||
webDAVConfigurator = page "Add a WebDAV repository" (Just Configuration)
|
||||
|
||||
boxConfigurator :: Widget -> Handler RepHtml
|
||||
boxConfigurator = page "Add a Box.com repository" (Just Config)
|
||||
boxConfigurator = page "Add a Box.com repository" (Just Configuration)
|
||||
|
||||
data WebDAVInput = WebDAVInput
|
||||
{ user :: Text
|
||||
|
|
|
|||
|
|
@ -48,7 +48,7 @@ xmppNeeded = return ()
|
|||
|
||||
getXMPPR :: Handler RepHtml
|
||||
#ifdef WITH_XMPP
|
||||
getXMPPR = getXMPPR' ConfigR
|
||||
getXMPPR = getXMPPR' ConfigurationR
|
||||
#else
|
||||
getXMPPR = xmppPage $
|
||||
$(widgetFile "configurators/xmpp/disabled")
|
||||
|
|
@ -155,4 +155,4 @@ testXMPP creds = either Left (const $ Right creds)
|
|||
#endif
|
||||
|
||||
xmppPage :: Widget -> Handler RepHtml
|
||||
xmppPage = page "Jabber" (Just Config)
|
||||
xmppPage = page "Jabber" (Just Configuration)
|
||||
|
|
|
|||
|
|
@ -79,7 +79,7 @@ dashboard warnNoScript = do
|
|||
|
||||
getHomeR :: Handler RepHtml
|
||||
getHomeR = ifM (inFirstRun)
|
||||
( redirect ConfigR
|
||||
( redirect ConfigurationR
|
||||
, page "" (Just DashBoard) $ dashboard True
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -19,24 +19,24 @@ import Yesod
|
|||
import Text.Hamlet
|
||||
import Data.Text (Text)
|
||||
|
||||
data NavBarItem = DashBoard | Config | About
|
||||
data NavBarItem = DashBoard | Configuration | About
|
||||
deriving (Eq)
|
||||
|
||||
navBarName :: NavBarItem -> Text
|
||||
navBarName DashBoard = "Dashboard"
|
||||
navBarName Config = "Configuration"
|
||||
navBarName Configuration = "Configuration"
|
||||
navBarName About = "About"
|
||||
|
||||
navBarRoute :: NavBarItem -> Route WebApp
|
||||
navBarRoute DashBoard = HomeR
|
||||
navBarRoute Config = ConfigR
|
||||
navBarRoute Configuration = ConfigurationR
|
||||
navBarRoute About = AboutR
|
||||
|
||||
defaultNavBar :: [NavBarItem]
|
||||
defaultNavBar = [DashBoard, Config, About]
|
||||
defaultNavBar = [DashBoard, Configuration, About]
|
||||
|
||||
firstRunNavBar :: [NavBarItem]
|
||||
firstRunNavBar = [Config, About]
|
||||
firstRunNavBar = [Configuration, About]
|
||||
|
||||
selectNavBar :: Handler [NavBarItem]
|
||||
selectNavBar = ifM (inFirstRun) (return firstRunNavBar, return defaultNavBar)
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@
|
|||
/about/license LicenseR GET
|
||||
/about/repogroups RepoGroupR GET
|
||||
|
||||
/config ConfigR GET
|
||||
/config ConfigurationR GET
|
||||
/config/repository RepositoriesR GET
|
||||
/config/xmpp XMPPR GET
|
||||
/config/xmpp/for/pairing XMPPForPairingR GET
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue