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 2012-12-29 23:10:18 -04:00
parent b62753c475
commit 7f7c31df1c
23 changed files with 151 additions and 103 deletions

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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

View file

@ -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")

View file

@ -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 $

View file

@ -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

View file

@ -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

View file

@ -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)

View file

@ -79,7 +79,7 @@ dashboard warnNoScript = do
getHomeR :: Handler RepHtml
getHomeR = ifM (inFirstRun)
( redirect ConfigR
( redirect ConfigurationR
, page "" (Just DashBoard) $ dashboard True
)

View file

@ -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)

View file

@ -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