diff --git a/Annex.hs b/Annex.hs index 8233e18b9f..4cad1d5e29 100644 --- a/Annex.hs +++ b/Annex.hs @@ -28,6 +28,7 @@ module Annex ( getGitConfig, changeGitConfig, changeGitRepo, + getRemoteGitConfig, withCurrentState, ) where @@ -267,6 +268,13 @@ changeGitRepo r = changeState $ \s -> s , gitconfig = extractGitConfig r } +{- Gets the RemoteGitConfig from a remote, given the Git.Repo for that + - remote. -} +getRemoteGitConfig :: Git.Repo -> Annex RemoteGitConfig +getRemoteGitConfig r = do + g <- gitRepo + return $ extractRemoteGitConfig g (Git.repoDescribe r) + {- Converts an Annex action into an IO action, that runs with a copy - of the current Annex state. - diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs index 1594801217..21bb83e28f 100644 --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -16,6 +16,8 @@ module Annex.Ssh ( sshCachingTo, inRepoWithSshCachingTo, runSshCaching, + sshAskPassEnv, + runSshAskPass ) where import qualified Data.Map as M @@ -230,7 +232,7 @@ sshReadPort params = (port, reverse args) {- When this env var is set, git-annex runs ssh with parameters - to use the socket file that the env var contains. - - - This is a workaround for GiT_SSH not being able to contain + - This is a workaround for GIT_SSH not being able to contain - additional parameters to pass to ssh. -} sshCachingEnv :: String sshCachingEnv = "GIT_ANNEX_SSHCACHING" @@ -268,8 +270,17 @@ sshCachingTo remote g where uncached = return g -runSshCaching :: [String] -> String -> IO () +runSshCaching :: [String] -> FilePath -> IO () runSshCaching args sockfile = do let args' = toCommand (sshConnectionCachingParams sockfile) ++ args let p = proc "ssh" args' exitWith =<< waitForProcess . processHandle =<< createProcess p + +{- When this env var is set, git-annex is being used as a ssh-askpass + - program, and should read the password from the specified location, + - and output it for ssh to read. -} +sshAskPassEnv :: String +sshAskPassEnv = "GIT_ANNEX_SSHASKPASS" + +runSshAskPass :: FilePath -> IO () +runSshAskPass passfile = putStrLn =<< readFile passfile diff --git a/Assistant.hs b/Assistant.hs index b5caceac2d..5dd6a7ece5 100644 --- a/Assistant.hs +++ b/Assistant.hs @@ -84,9 +84,7 @@ startDaemon assistant foreground startdelay cannotrun listenhost startbrowser = fdToHandle =<< dup stdError let undaemonize a = do debugM desc $ "logging to " ++ logfile - Utility.Daemon.lockPidFile pidfile - Utility.LogFile.redirLog logfd - a + Utility.Daemon.foreground logfd (Just pidfile) a start undaemonize $ case startbrowser of Nothing -> Nothing diff --git a/Assistant/CredPairCache.hs b/Assistant/CredPairCache.hs new file mode 100644 index 0000000000..2b8f72e7cd --- /dev/null +++ b/Assistant/CredPairCache.hs @@ -0,0 +1,53 @@ +{- git-annex assistant CredPair cache. + - + - Copyright 2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE BangPatterns #-} + +module Assistant.CredPairCache ( + cacheCred, + getCachedCred, + expireCachedCred, +) where + +import Assistant.Types.CredPairCache +import Types.Creds +import Assistant.Common +import Utility.ThreadScheduler + +import qualified Data.Map as M +import Control.Concurrent + +{- Caches a CredPair, but only for a limited time, after which it + - will expire. + - + - Note that repeatedly caching the same CredPair + - does not reset its expiry time. + -} +cacheCred :: CredPair -> Seconds -> Assistant () +cacheCred (login, password) expireafter = do + cache <- getAssistant credPairCache + liftIO $ do + changeStrict cache $ M.insert login password + void $ forkIO $ do + threadDelaySeconds expireafter + changeStrict cache $ M.delete login + +getCachedCred :: Login -> Assistant (Maybe Password) +getCachedCred login = do + cache <- getAssistant credPairCache + liftIO $ M.lookup login <$> readMVar cache + +expireCachedCred :: Login -> Assistant () +expireCachedCred login = do + cache <- getAssistant credPairCache + liftIO $ changeStrict cache $ M.delete login + +{- Update map strictly to avoid keeping references to old creds in memory. -} +changeStrict :: CredPairCache -> (M.Map Login Password -> M.Map Login Password) -> IO () +changeStrict cache a = modifyMVar_ cache $ \m -> do + let !m' = a m + return m' diff --git a/Assistant/Monad.hs b/Assistant/Monad.hs index 350e3d33ba..5b3f5abb4d 100644 --- a/Assistant/Monad.hs +++ b/Assistant/Monad.hs @@ -44,6 +44,7 @@ import Assistant.Types.Buddies import Assistant.Types.NetMessager import Assistant.Types.ThreadName import Assistant.Types.RemoteControl +import Assistant.Types.CredPairCache newtype Assistant a = Assistant { mkAssistant :: ReaderT AssistantData IO a } deriving ( @@ -70,6 +71,7 @@ data AssistantData = AssistantData , buddyList :: BuddyList , netMessager :: NetMessager , remoteControl :: RemoteControl + , credPairCache :: CredPairCache } newAssistantData :: ThreadState -> DaemonStatusHandle -> IO AssistantData @@ -89,6 +91,7 @@ newAssistantData st dstatus = AssistantData <*> newBuddyList <*> newNetMessager <*> newRemoteControl + <*> newCredPairCache runAssistant :: AssistantData -> Assistant a -> IO a runAssistant d a = runReaderT (mkAssistant a) d diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs index 39ae67537f..bd7aad69c2 100644 --- a/Assistant/Threads/MountWatcher.hs +++ b/Assistant/Threads/MountWatcher.hs @@ -63,7 +63,11 @@ dbusThread urlrenderer = do wasmounted <- liftIO $ swapMVar mvar nowmounted handleMounts urlrenderer wasmounted nowmounted liftIO $ forM_ mountChanged $ \matcher -> +#if MIN_VERSION_dbus(0,10,7) + void $ addMatch client matcher handleevent +#else listen client matcher handleevent +#endif , do liftAnnex $ warning "No known volume monitor available through dbus; falling back to mtab polling" diff --git a/Assistant/Threads/NetWatcher.hs b/Assistant/Threads/NetWatcher.hs index 9dd6178229..f8c456aacf 100644 --- a/Assistant/Threads/NetWatcher.hs +++ b/Assistant/Threads/NetWatcher.hs @@ -112,8 +112,13 @@ checkNetMonitor client = do -} listenNMConnections :: Client -> (Bool -> IO ()) -> IO () listenNMConnections client setconnected = - listen client matcher $ \event -> mapM_ handle - (map dictionaryItems $ mapMaybe fromVariant $ signalBody event) +#if MIN_VERSION_dbus(0,10,7) + void $ addMatch client matcher +#else + listen client matcher +#endif + $ \event -> mapM_ handle + (map dictionaryItems $ mapMaybe fromVariant $ signalBody event) where matcher = matchAny { matchInterface = Just "org.freedesktop.NetworkManager" @@ -142,10 +147,10 @@ listenNMConnections client setconnected = -} listenWicdConnections :: Client -> (Bool -> IO ()) -> IO () listenWicdConnections client setconnected = do - listen client connmatcher $ \event -> + match connmatcher $ \event -> when (any (== wicd_success) (signalBody event)) $ setconnected True - listen client statusmatcher $ \event -> handle (signalBody event) + match statusmatcher $ \event -> handle (signalBody event) where connmatcher = matchAny { matchInterface = Just "org.wicd.daemon" @@ -160,7 +165,12 @@ listenWicdConnections client setconnected = do handle status | any (== wicd_disconnected) status = setconnected False | otherwise = noop - + match matcher a = +#if MIN_VERSION_dbus(0,10,7) + void $ addMatch client matcher a +#else + listen client matcher a +#endif #endif handleConnection :: Assistant () diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs index d7a71d4770..ba141698d7 100644 --- a/Assistant/Threads/SanityChecker.hs +++ b/Assistant/Threads/SanityChecker.hs @@ -46,6 +46,7 @@ import Assistant.WebApp.Types #ifndef mingw32_HOST_OS import Utility.LogFile #endif +import Types.Key (keyBackendName) import Data.Time.Clock.POSIX import qualified Data.Text as T @@ -82,6 +83,10 @@ sanityCheckerStartupThread startupdelay = namedThreadUnchecked "SanityCheckerSta {- Fix up ssh remotes set up by past versions of the assistant. -} liftIO $ fixUpSshRemotes + {- Clean up old temp files. -} + liftAnnex cleanOldTmpMisc + liftAnnex cleanReallyOldTmp + {- If there's a startup delay, it's done here. -} liftIO $ maybe noop (threadDelaySeconds . Seconds . fromIntegral . durationSeconds) startupdelay @@ -258,3 +263,54 @@ checkOldUnused urlrenderer = go =<< annexExpireUnused <$> liftAnnex Annex.getGit #else debug [show $ renderTense Past msg] #endif + +{- Files may be left in misctmp by eg, an interrupted add of files + - by the assistant, which hard links files to there as part of lockdown + - checks. Delete these files if they're more than a day old. + - + - Note that this is not safe to run after the Watcher starts up, since it + - will create such files, and due to hard linking they may have old + - mtimes. So, this should only be called from the + - sanityCheckerStartupThread, which runs before the Watcher starts up. + - + - Also, if a git-annex add is being run at the same time the assistant + - starts up, its tmp files could be deleted. However, the watcher will + - come along and add everything once it starts up anyway, so at worst + - this would make the git-annex add fail unexpectedly. + -} +cleanOldTmpMisc :: Annex () +cleanOldTmpMisc = do + now <- liftIO getPOSIXTime + let oldenough = now - (60 * 60 * 24) + tmp <- fromRepo gitAnnexTmpMiscDir + liftIO $ mapM_ (cleanOld (<= oldenough)) =<< dirContentsRecursive tmp + +{- While .git/annex/tmp is now only used for storing partially transferred + - objects, older versions of git-annex used it for misctemp. Clean up any + - files that might be left from that, by looking for files whose names + - cannot be the key of an annexed object. Only delete files older than + - 1 week old. + - + - Also, some remotes such as rsync may use this temp directory for storing + - eg, encrypted objects that are being transferred. So, delete old + - objects that use a GPGHMAC backend. + -} +cleanReallyOldTmp :: Annex () +cleanReallyOldTmp = do + now <- liftIO getPOSIXTime + let oldenough = now - (60 * 60 * 24 * 7) + tmp <- fromRepo gitAnnexTmpObjectDir + liftIO $ mapM_ (cleanjunk (<= oldenough)) =<< dirContentsRecursive tmp + where + cleanjunk check f = case fileKey (takeFileName f) of + Nothing -> cleanOld check f + Just k + | "GPGHMAC" `isPrefixOf` keyBackendName k -> + cleanOld check f + | otherwise -> noop + +cleanOld :: (POSIXTime -> Bool) -> FilePath -> IO () +cleanOld check f = do + mtime <- realToFrac . modificationTime <$> getFileStatus f + when (check mtime) $ + nukeFile f diff --git a/Assistant/Threads/Upgrader.hs b/Assistant/Threads/Upgrader.hs index 60aeec70b6..637c82a7d9 100644 --- a/Assistant/Threads/Upgrader.hs +++ b/Assistant/Threads/Upgrader.hs @@ -18,11 +18,8 @@ import Assistant.Types.UrlRenderer import Assistant.DaemonStatus import Assistant.Alert import Utility.NotificationBroadcaster -import Utility.Tmp import qualified Annex import qualified Build.SysConfig -import qualified Utility.Url as Url -import qualified Annex.Url as Url import qualified Git.Version import Types.Distribution #ifdef WITH_WEBAPP @@ -62,7 +59,7 @@ upgraderThread urlrenderer = namedThread "Upgrader" $ checkUpgrade :: UrlRenderer -> Assistant () checkUpgrade urlrenderer = do debug [ "Checking if an upgrade is available." ] - go =<< getDistributionInfo + go =<< downloadDistributionInfo where go Nothing = debug [ "Failed to check if upgrade is available." ] go (Just d) = do @@ -86,16 +83,3 @@ canUpgrade urgency urlrenderer d = ifM autoUpgradeEnabled noop #endif ) - -getDistributionInfo :: Assistant (Maybe GitAnnexDistribution) -getDistributionInfo = do - uo <- liftAnnex Url.getUrlOptions - liftIO $ withTmpFile "git-annex.tmp" $ \tmpfile h -> do - hClose h - ifM (Url.downloadQuiet distributionInfoUrl tmpfile uo) - ( readish <$> readFileStrict tmpfile - , return Nothing - ) - -distributionInfoUrl :: String -distributionInfoUrl = fromJust Build.SysConfig.upgradelocation ++ ".info" diff --git a/Assistant/Types/CredPairCache.hs b/Assistant/Types/CredPairCache.hs new file mode 100644 index 0000000000..a1e11c2571 --- /dev/null +++ b/Assistant/Types/CredPairCache.hs @@ -0,0 +1,18 @@ +{- git-annex assistant CredPair cache. + - + - Copyright 2014 Joey Hess + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Types.CredPairCache where + +import Types.Creds + +import Control.Concurrent +import qualified Data.Map as M + +type CredPairCache = MVar (M.Map Login Password) + +newCredPairCache :: IO CredPairCache +newCredPairCache = newMVar M.empty diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs index aaf6a8478b..c7ff7676b3 100644 --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -32,7 +32,11 @@ import Config.Files import Utility.ThreadScheduler import Utility.Tmp import Utility.UserInfo +import Utility.Gpg import qualified Utility.Lsof as Lsof +import qualified Build.SysConfig +import qualified Utility.Url as Url +import qualified Annex.Url as Url import qualified Data.Map as M import Data.Tuple.Utils @@ -313,3 +317,48 @@ upgradeSanityCheck = ifM usingDistribution usingDistribution :: IO Bool usingDistribution = isJust <$> getEnv "GIT_ANNEX_STANDLONE_ENV" + +downloadDistributionInfo :: Assistant (Maybe GitAnnexDistribution) +downloadDistributionInfo = do + uo <- liftAnnex Url.getUrlOptions + liftIO $ withTmpDir "git-annex.tmp" $ \tmpdir -> do + let infof = tmpdir "info" + let sigf = infof ++ ".sig" + ifM (Url.downloadQuiet distributionInfoUrl infof uo + <&&> Url.downloadQuiet distributionInfoSigUrl sigf uo + <&&> verifyDistributionSig sigf) + ( readish <$> readFileStrict infof + , return Nothing + ) + +distributionInfoUrl :: String +distributionInfoUrl = fromJust Build.SysConfig.upgradelocation ++ ".info" + +distributionInfoSigUrl :: String +distributionInfoSigUrl = distributionInfoUrl ++ ".sig" + +{- Verifies that a file from the git-annex distribution has a valid + - signature. Pass the detached .sig file; the file to be verified should + - be located next to it. + - + - The gpg keyring used to verify the signature is located in + - trustedkeys.gpg, next to the git-annex program. + -} +verifyDistributionSig :: FilePath -> IO Bool +verifyDistributionSig sig = do + p <- readProgramFile + if isAbsolute p + then withTmpDir "git-annex-gpg.tmp" $ \gpgtmp -> do + let trustedkeys = takeDirectory p "trustedkeys.gpg" + boolSystem gpgcmd + [ Param "--no-default-keyring" + , Param "--no-auto-check-trustdb" + , Param "--no-options" + , Param "--homedir" + , File gpgtmp + , Param "--keyring" + , File trustedkeys + , Param "--verify" + , File sig + ] + else return False diff --git a/Assistant/WebApp/Bootstrap3.hs b/Assistant/WebApp/Bootstrap3.hs new file mode 100644 index 0000000000..91a941c33d --- /dev/null +++ b/Assistant/WebApp/Bootstrap3.hs @@ -0,0 +1,284 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +-- | Helper functions for creating forms when using Bootstrap v3. +-- This is a copy of the Yesod.Form.Bootstrap3 module that has been slightly +-- modified to be compatible with Yesod 1.0.1 +module Assistant.WebApp.Bootstrap3 + ( -- * Rendering forms + renderBootstrap3 + , BootstrapFormLayout(..) + , BootstrapGridOptions(..) + -- * Field settings + , bfs + , withPlaceholder + , withAutofocus + , withLargeInput + , withSmallInput + -- * Submit button + , bootstrapSubmit + , mbootstrapSubmit + , BootstrapSubmit(..) + ) where + +import Control.Arrow (second) +import Control.Monad (liftM) +import Data.Text (Text) +import Data.String (IsString(..)) +import Yesod.Core + +import qualified Data.Text as T + +import Yesod.Form.Types +import Yesod.Form.Functions + +-- | Create a new 'FieldSettings' with the classes that are +-- required by Bootstrap v3. +-- +-- Since: yesod-form 1.3.8 +bfs :: RenderMessage site msg => msg -> FieldSettings site +bfs msg = + FieldSettings (SomeMessage msg) Nothing Nothing Nothing [("class", "form-control")] + + +-- | Add a placeholder attribute to a field. If you need i18n +-- for the placeholder, currently you\'ll need to do a hack and +-- use 'getMessageRender' manually. +-- +-- Since: yesod-form 1.3.8 +withPlaceholder :: Text -> FieldSettings site -> FieldSettings site +withPlaceholder placeholder fs = fs { fsAttrs = newAttrs } + where newAttrs = ("placeholder", placeholder) : fsAttrs fs + + +-- | Add an autofocus attribute to a field. +-- +-- Since: yesod-form 1.3.8 +withAutofocus :: FieldSettings site -> FieldSettings site +withAutofocus fs = fs { fsAttrs = newAttrs } + where newAttrs = ("autofocus", "autofocus") : fsAttrs fs + + +-- | Add the @input-lg@ CSS class to a field. +-- +-- Since: yesod-form 1.3.8 +withLargeInput :: FieldSettings site -> FieldSettings site +withLargeInput fs = fs { fsAttrs = newAttrs } + where newAttrs = addClass "input-lg" (fsAttrs fs) + + +-- | Add the @input-sm@ CSS class to a field. +-- +-- Since: yesod-form 1.3.8 +withSmallInput :: FieldSettings site -> FieldSettings site +withSmallInput fs = fs { fsAttrs = newAttrs } + where newAttrs = addClass "input-sm" (fsAttrs fs) + + +addClass :: Text -> [(Text, Text)] -> [(Text, Text)] +addClass klass [] = [("class", klass)] +addClass klass (("class", old):rest) = ("class", T.concat [old, " ", klass]) : rest +addClass klass (other :rest) = other : addClass klass rest + + +-- | How many bootstrap grid columns should be taken (see +-- 'BootstrapFormLayout'). +-- +-- Since: yesod-form 1.3.8 +data BootstrapGridOptions = + ColXs !Int + | ColSm !Int + | ColMd !Int + | ColLg !Int + deriving (Eq, Ord, Show) + +toColumn :: BootstrapGridOptions -> String +toColumn (ColXs 0) = "" +toColumn (ColSm 0) = "" +toColumn (ColMd 0) = "" +toColumn (ColLg 0) = "" +toColumn (ColXs columns) = "col-xs-" ++ show columns +toColumn (ColSm columns) = "col-sm-" ++ show columns +toColumn (ColMd columns) = "col-md-" ++ show columns +toColumn (ColLg columns) = "col-lg-" ++ show columns + +toOffset :: BootstrapGridOptions -> String +toOffset (ColXs 0) = "" +toOffset (ColSm 0) = "" +toOffset (ColMd 0) = "" +toOffset (ColLg 0) = "" +toOffset (ColXs columns) = "col-xs-offset-" ++ show columns +toOffset (ColSm columns) = "col-sm-offset-" ++ show columns +toOffset (ColMd columns) = "col-md-offset-" ++ show columns +toOffset (ColLg columns) = "col-lg-offset-" ++ show columns + +addGO :: BootstrapGridOptions -> BootstrapGridOptions -> BootstrapGridOptions +addGO (ColXs a) (ColXs b) = ColXs (a+b) +addGO (ColSm a) (ColSm b) = ColSm (a+b) +addGO (ColMd a) (ColMd b) = ColMd (a+b) +addGO (ColLg a) (ColLg b) = ColLg (a+b) +addGO a b | a > b = addGO b a +addGO (ColXs a) other = addGO (ColSm a) other +addGO (ColSm a) other = addGO (ColMd a) other +addGO (ColMd a) other = addGO (ColLg a) other +addGO (ColLg _) _ = error "Yesod.Form.Bootstrap.addGO: never here" + + +-- | The layout used for the bootstrap form. +-- +-- Since: yesod-form 1.3.8 +data BootstrapFormLayout = + BootstrapBasicForm + | BootstrapInlineForm + | BootstrapHorizontalForm + { bflLabelOffset :: !BootstrapGridOptions + , bflLabelSize :: !BootstrapGridOptions + , bflInputOffset :: !BootstrapGridOptions + , bflInputSize :: !BootstrapGridOptions + } + deriving (Show) + + +-- | Render the given form using Bootstrap v3 conventions. +-- +-- Sample Hamlet for 'BootstrapHorizontalForm': +-- +-- >
+-- > ^{formWidget} +-- > ^{bootstrapSubmit MsgSubmit} +-- +-- Since: yesod-form 1.3.8 +#if MIN_VERSION_yesod(1,2,0) +renderBootstrap3 :: Monad m => BootstrapFormLayout -> FormRender m a +#else +renderBootstrap3 :: BootstrapFormLayout -> FormRender sub master a +#endif +renderBootstrap3 formLayout aform fragment = do + (res, views') <- aFormToForm aform + let views = views' [] + has (Just _) = True + has Nothing = False + widget = [whamlet| +#if MIN_VERSION_yesod(1,2,0) + $newline never +#endif + #{fragment} + $forall view <- views +
+ $case formLayout + $of BootstrapBasicForm + $if nequals (fvId view) bootstrapSubmitId +