webapp and assistant glacier support
This commit is contained in:
Joey Hess
parent
c282c8b492
commit
463cf58140
23 changed files with 321 additions and 185 deletions
|
|
@ -19,18 +19,19 @@ import Annex.Wanted
|
|||
import Config
|
||||
|
||||
{- Drop from local and/or remote when allowed by the preferred content and
|
||||
- numcopies settings. -}
|
||||
handleDrops :: Bool -> Key -> AssociatedFile -> Assistant ()
|
||||
handleDrops _ _ Nothing = noop
|
||||
handleDrops fromhere key f = do
|
||||
- numcopies settings. If it's known to be present on a particular remote,
|
||||
- -}
|
||||
handleDrops :: Bool -> Key -> AssociatedFile -> Maybe Remote -> Assistant ()
|
||||
handleDrops _ _ Nothing _ = noop
|
||||
handleDrops fromhere key f knownpresentremote = do
|
||||
syncrs <- syncDataRemotes <$> getDaemonStatus
|
||||
liftAnnex $ do
|
||||
locs <- loggedLocations key
|
||||
handleDrops' locs syncrs fromhere key f
|
||||
handleDrops' locs syncrs fromhere key f knownpresentremote
|
||||
|
||||
handleDrops' :: [UUID] -> [Remote] -> Bool -> Key -> AssociatedFile -> Annex ()
|
||||
handleDrops' _ _ _ _ Nothing = noop
|
||||
handleDrops' locs rs fromhere key (Just f)
|
||||
handleDrops' :: [UUID] -> [Remote] -> Bool -> Key -> AssociatedFile -> Maybe Remote -> Annex ()
|
||||
handleDrops' _ _ _ _ Nothing _ = noop
|
||||
handleDrops' locs rs fromhere key (Just f) knownpresentremote
|
||||
| fromhere = do
|
||||
n <- getcopies
|
||||
if checkcopies n
|
||||
|
|
@ -59,7 +60,7 @@ handleDrops' locs rs fromhere key (Just f)
|
|||
)
|
||||
|
||||
dropl n = checkdrop n Nothing $ \numcopies ->
|
||||
Command.Drop.startLocal f numcopies key
|
||||
Command.Drop.startLocal f numcopies key knownpresentremote
|
||||
|
||||
dropr r n = checkdrop n (Just $ Remote.uuid r) $ \numcopies ->
|
||||
Command.Drop.startRemote f numcopies key r
|
||||
|
|
|
|||
|
|
@ -119,7 +119,7 @@ expensiveScan rs = unless onlyweb $ do
|
|||
locs <- loggedLocations key
|
||||
present <- inAnnex key
|
||||
|
||||
handleDrops' locs syncrs present key (Just f)
|
||||
handleDrops' locs syncrs present key (Just f) Nothing
|
||||
|
||||
let slocs = S.fromList locs
|
||||
let use a = return $ catMaybes $ map (a key slocs) syncrs
|
||||
|
|
|
|||
|
|
@ -102,11 +102,11 @@ onDel file = case parseTransferFile file of
|
|||
threadDelay 10000000 -- 10 seconds
|
||||
finished t minfo
|
||||
|
||||
{- Queue uploads of files we successfully downloaded, spreading them
|
||||
{- Queue uploads of files downloaded to us, spreading them
|
||||
- out to other reachable remotes.
|
||||
-
|
||||
- Downloading a file may have caused a remote to not want it;
|
||||
- so drop it from the remote.
|
||||
- so check for drops from remotes.
|
||||
-
|
||||
- Uploading a file may cause the local repo, or some other remote to not
|
||||
- want it; handle that too.
|
||||
|
|
@ -115,9 +115,9 @@ finishedTransfer :: Transfer -> Maybe TransferInfo -> Assistant ()
|
|||
finishedTransfer t (Just info)
|
||||
| transferDirection t == Download =
|
||||
whenM (liftAnnex $ inAnnex $ transferKey t) $ do
|
||||
handleDrops False (transferKey t) (associatedFile info)
|
||||
handleDrops False (transferKey t) (associatedFile info) Nothing
|
||||
queueTransfersMatching (/= transferUUID t) Later
|
||||
(transferKey t) (associatedFile info) Upload
|
||||
| otherwise = handleDrops True (transferKey t) (associatedFile info)
|
||||
| otherwise = handleDrops True (transferKey t) (associatedFile info) Nothing
|
||||
finishedTransfer _ _ = noop
|
||||
|
||||
|
|
|
|||
|
|
@ -13,6 +13,7 @@ import Assistant.TransferQueue
|
|||
import Assistant.TransferSlots
|
||||
import Assistant.Alert
|
||||
import Assistant.Commits
|
||||
import Assistant.Drop
|
||||
import Logs.Transfer
|
||||
import Logs.Location
|
||||
import Annex.Content
|
||||
|
|
@ -65,6 +66,10 @@ startTransfer program t info = case (transferRemote info, associatedFile info) o
|
|||
- so there's no point in bothering the user about
|
||||
- those. The assistant should recover.
|
||||
-
|
||||
- After a successful upload, handle dropping it from
|
||||
- here, if desired. In this case, the remote it was
|
||||
- uploaded to is known to have it.
|
||||
-
|
||||
- Also, after a successful transfer, the location
|
||||
- log has changed. Indicate that a commit has been
|
||||
- made, in order to queue a push of the git-annex
|
||||
|
|
@ -74,6 +79,10 @@ startTransfer program t info = case (transferRemote info, associatedFile info) o
|
|||
whenM (liftIO $ (==) ExitSuccess <$> waitForProcess pid) $ do
|
||||
void $ addAlert $ makeAlertFiller True $
|
||||
transferFileAlert direction True file
|
||||
unless isdownload $
|
||||
handleDrops True (transferKey t)
|
||||
(associatedFile info)
|
||||
(Just remote)
|
||||
recordCommit
|
||||
where
|
||||
params =
|
||||
|
|
|
|||
|
|
@ -187,7 +187,7 @@ onAddSymlink file filestatus = go =<< liftAnnex (Backend.lookupFile file)
|
|||
if present
|
||||
then queueTransfers Next key (Just file) Upload
|
||||
else queueTransfers Next key (Just file) Download
|
||||
handleDrops present key (Just file)
|
||||
handleDrops present key (Just file) Nothing
|
||||
| otherwise = noop
|
||||
|
||||
onDel :: Handler
|
||||
|
|
|
|||
|
|
@ -21,9 +21,7 @@ import Assistant.WebApp.Configurators.Edit
|
|||
import Assistant.WebApp.Configurators.Local
|
||||
import Assistant.WebApp.Configurators.Ssh
|
||||
import Assistant.WebApp.Configurators.Pairing
|
||||
#ifdef WITH_S3
|
||||
import Assistant.WebApp.Configurators.S3
|
||||
#endif
|
||||
import Assistant.WebApp.Configurators.AWS
|
||||
#ifdef WITH_WEBDAV
|
||||
import Assistant.WebApp.Configurators.WebDAV
|
||||
#endif
|
||||
|
|
|
|||
|
|
@ -176,6 +176,7 @@ repoList reposelector
|
|||
#ifdef WITH_S3
|
||||
Just "S3" -> val True EnableS3R
|
||||
#endif
|
||||
Just "glacier" -> val True EnableGlacierR
|
||||
#ifdef WITH_WEBDAV
|
||||
Just "webdav" -> val True EnableWebDAVR
|
||||
#endif
|
||||
|
|
|
|||
177
Assistant/WebApp/Configurators/AWS.hs
Normal file
177
Assistant/WebApp/Configurators/AWS.hs
Normal file
|
|
@ -0,0 +1,177 @@
|
|||
{- git-annex assistant webapp configurators for Amazon AWS services
|
||||
-
|
||||
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE CPP, TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
|
||||
|
||||
module Assistant.WebApp.Configurators.AWS where
|
||||
|
||||
import Assistant.Common
|
||||
import Assistant.MakeRemote
|
||||
import Assistant.Sync
|
||||
import Assistant.WebApp
|
||||
import Assistant.WebApp.Types
|
||||
import Assistant.WebApp.SideBar
|
||||
import Utility.Yesod
|
||||
#ifdef WITH_S3
|
||||
import qualified Remote.S3 as S3
|
||||
#endif
|
||||
import qualified Remote.Glacier as Glacier
|
||||
import qualified Remote.Helper.AWS as AWS
|
||||
import Logs.Remote
|
||||
import qualified Remote
|
||||
import Types.Remote (RemoteConfig)
|
||||
import Types.StandardGroups
|
||||
import Logs.PreferredContent
|
||||
|
||||
import Yesod
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Map as M
|
||||
|
||||
awsConfigurator :: Widget -> Handler RepHtml
|
||||
awsConfigurator a = bootstrap (Just Config) $ do
|
||||
sideBarDisplay
|
||||
setTitle "Add an Amazon repository"
|
||||
a
|
||||
|
||||
glacierConfigurator :: Widget -> Handler RepHtml
|
||||
glacierConfigurator a = do
|
||||
ifM (liftIO $ inPath "glacier")
|
||||
( awsConfigurator a
|
||||
, awsConfigurator needglaciercli
|
||||
)
|
||||
where
|
||||
needglaciercli = $(widgetFile "configurators/needglaciercli")
|
||||
|
||||
data StorageClass = StandardRedundancy | ReducedRedundancy
|
||||
deriving (Eq, Enum, Bounded)
|
||||
|
||||
instance Show StorageClass where
|
||||
show StandardRedundancy = "STANDARD"
|
||||
show ReducedRedundancy = "REDUCED_REDUNDANCY"
|
||||
|
||||
data AWSInput = AWSInput
|
||||
{ accessKeyID :: Text
|
||||
, secretAccessKey :: Text
|
||||
-- Free form text for datacenter because Amazon adds new ones.
|
||||
, datacenter :: Text
|
||||
-- Only used for S3, not Glacier.
|
||||
, storageClass :: StorageClass
|
||||
, repoName :: Text
|
||||
}
|
||||
|
||||
data AWSCreds = AWSCreds Text Text
|
||||
|
||||
extractCreds :: AWSInput -> AWSCreds
|
||||
extractCreds i = AWSCreds (accessKeyID i) (secretAccessKey i)
|
||||
|
||||
s3InputAForm :: AForm WebApp WebApp AWSInput
|
||||
s3InputAForm = AWSInput
|
||||
<$> areq textField "Access Key ID" Nothing
|
||||
<*> areq passwordField "Secret Access Key" Nothing
|
||||
<*> areq textField "Datacenter" (Just "US")
|
||||
<*> areq (selectFieldList storageclasses) "Storage class" (Just StandardRedundancy)
|
||||
<*> areq textField "Repository name" (Just "S3")
|
||||
where
|
||||
storageclasses :: [(Text, StorageClass)]
|
||||
storageclasses =
|
||||
[ ("Standard redundancy", StandardRedundancy)
|
||||
, ("Reduced redundancy (costs less)", ReducedRedundancy)
|
||||
]
|
||||
|
||||
glacierInputAForm :: AForm WebApp WebApp AWSInput
|
||||
glacierInputAForm = AWSInput
|
||||
<$> areq textField "Access Key ID" Nothing
|
||||
<*> areq passwordField "Secret Access Key" Nothing
|
||||
<*> areq textField "Datacenter" (Just "us-east-1")
|
||||
<*> pure StandardRedundancy
|
||||
<*> areq textField "Repository name" (Just "glacier")
|
||||
|
||||
awsCredsAForm :: AForm WebApp WebApp AWSCreds
|
||||
awsCredsAForm = AWSCreds
|
||||
<$> areq textField "Access Key ID" Nothing
|
||||
<*> areq passwordField "Secret Access Key" Nothing
|
||||
|
||||
getAddS3R :: Handler RepHtml
|
||||
#ifdef WITH_S3
|
||||
getAddS3R = awsConfigurator $ do
|
||||
((result, form), enctype) <- lift $
|
||||
runFormGet $ renderBootstrap s3InputAForm
|
||||
case result of
|
||||
FormSuccess input -> lift $ do
|
||||
let name = T.unpack $ repoName input
|
||||
makeAWSRemote S3.remote (extractCreds input) name setgroup $ M.fromList
|
||||
[ ("encryption", "shared")
|
||||
, ("type", "S3")
|
||||
, ("datacenter", T.unpack $ datacenter input)
|
||||
, ("storageclass", show $ storageClass input)
|
||||
]
|
||||
_ -> do
|
||||
let authtoken = webAppFormAuthToken
|
||||
$(widgetFile "configurators/adds3")
|
||||
where
|
||||
setgroup r = runAnnex () $
|
||||
setStandardGroup (Remote.uuid r) TransferGroup
|
||||
#else
|
||||
getAddS3R = error "S3 not supported by this build"
|
||||
#endif
|
||||
|
||||
getAddGlacierR :: Handler RepHtml
|
||||
getAddGlacierR = glacierConfigurator $ do
|
||||
((result, form), enctype) <- lift $
|
||||
runFormGet $ renderBootstrap glacierInputAForm
|
||||
case result of
|
||||
FormSuccess input -> lift $ do
|
||||
let name = T.unpack $ repoName input
|
||||
makeAWSRemote Glacier.remote (extractCreds input) name setgroup $ M.fromList
|
||||
[ ("encryption", "shared")
|
||||
, ("type", "glacier")
|
||||
, ("datacenter", T.unpack $ datacenter input)
|
||||
]
|
||||
_ -> do
|
||||
let authtoken = webAppFormAuthToken
|
||||
$(widgetFile "configurators/addglacier")
|
||||
where
|
||||
setgroup r = runAnnex () $
|
||||
setStandardGroup (Remote.uuid r) SmallArchiveGroup
|
||||
|
||||
getEnableS3R :: UUID -> Handler RepHtml
|
||||
#ifdef WITH_S3
|
||||
getEnableS3R = awsConfigurator . enableAWSRemote S3.remote
|
||||
#else
|
||||
getEnableS3R _ = error "S3 not supported by this build"
|
||||
#endif
|
||||
|
||||
getEnableGlacierR :: UUID -> Handler RepHtml
|
||||
getEnableGlacierR = glacierConfigurator . enableAWSRemote Glacier.remote
|
||||
|
||||
enableAWSRemote :: RemoteType -> UUID -> Widget
|
||||
enableAWSRemote remotetype uuid = do
|
||||
((result, form), enctype) <- lift $
|
||||
runFormGet $ renderBootstrap awsCredsAForm
|
||||
case result of
|
||||
FormSuccess creds -> lift $ do
|
||||
m <- runAnnex M.empty readRemoteLog
|
||||
let name = fromJust $ M.lookup "name" $
|
||||
fromJust $ M.lookup uuid m
|
||||
makeAWSRemote remotetype creds name (const noop) M.empty
|
||||
_ -> do
|
||||
let authtoken = webAppFormAuthToken
|
||||
description <- lift $ runAnnex "" $
|
||||
T.pack . concat <$> Remote.prettyListUUIDs [uuid]
|
||||
$(widgetFile "configurators/enableaws")
|
||||
|
||||
makeAWSRemote :: RemoteType -> AWSCreds -> String -> (Remote -> Handler ()) -> RemoteConfig -> Handler ()
|
||||
makeAWSRemote remotetype (AWSCreds ak sk) name setup config = do
|
||||
remotename <- runAnnex name $ fromRepo $ uniqueRemoteName name 0
|
||||
liftIO $ AWS.setCredsEnv (T.unpack ak, T.unpack sk)
|
||||
r <- liftAssistant $ liftAnnex $ addRemote $ do
|
||||
makeSpecialRemote name remotetype config
|
||||
return remotename
|
||||
setup r
|
||||
liftAssistant $ syncNewRemote r
|
||||
redirect $ EditNewCloudRepositoryR $ Remote.uuid r
|
||||
|
|
@ -1,123 +0,0 @@
|
|||
{- git-annex assistant webapp configurator for Amazon S3
|
||||
-
|
||||
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
||||
-
|
||||
- Licensed under the GNU AGPL version 3 or higher.
|
||||
-}
|
||||
|
||||
{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
|
||||
|
||||
module Assistant.WebApp.Configurators.S3 where
|
||||
|
||||
import Assistant.Common
|
||||
import Assistant.MakeRemote
|
||||
import Assistant.Sync
|
||||
import Assistant.WebApp
|
||||
import Assistant.WebApp.Types
|
||||
import Assistant.WebApp.SideBar
|
||||
import Utility.Yesod
|
||||
import qualified Remote.S3 as S3
|
||||
import qualified Remote.Helper.AWS as AWS
|
||||
import Logs.Remote
|
||||
import qualified Remote
|
||||
import Types.Remote (RemoteConfig)
|
||||
import Types.StandardGroups
|
||||
import Logs.PreferredContent
|
||||
|
||||
import Yesod
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Map as M
|
||||
|
||||
s3Configurator :: Widget -> Handler RepHtml
|
||||
s3Configurator a = bootstrap (Just Config) $ do
|
||||
sideBarDisplay
|
||||
setTitle "Add an Amazon S3 repository"
|
||||
a
|
||||
|
||||
data StorageClass = StandardRedundancy | ReducedRedundancy
|
||||
deriving (Eq, Enum, Bounded)
|
||||
|
||||
instance Show StorageClass where
|
||||
show StandardRedundancy = "STANDARD"
|
||||
show ReducedRedundancy = "REDUCED_REDUNDANCY"
|
||||
|
||||
data S3Input = S3Input
|
||||
{ accessKeyID :: Text
|
||||
, secretAccessKey :: Text
|
||||
-- Free form text for datacenter because Amazon adds new ones.
|
||||
, datacenter :: Text
|
||||
, storageClass :: StorageClass
|
||||
, repoName :: Text
|
||||
}
|
||||
|
||||
data S3Creds = S3Creds Text Text
|
||||
|
||||
extractCreds :: S3Input -> S3Creds
|
||||
extractCreds i = S3Creds (accessKeyID i) (secretAccessKey i)
|
||||
|
||||
s3InputAForm :: AForm WebApp WebApp S3Input
|
||||
s3InputAForm = S3Input
|
||||
<$> areq textField "Access Key ID" Nothing
|
||||
<*> areq passwordField "Secret Access Key" Nothing
|
||||
<*> areq textField "Datacenter" (Just "US")
|
||||
<*> areq (selectFieldList storageclasses) "Storage class" (Just StandardRedundancy)
|
||||
<*> areq textField "Repository name" (Just "S3")
|
||||
where
|
||||
storageclasses :: [(Text, StorageClass)]
|
||||
storageclasses =
|
||||
[ ("Standard redundancy", StandardRedundancy)
|
||||
, ("Reduced redundancy (costs less)", ReducedRedundancy)
|
||||
]
|
||||
|
||||
s3CredsAForm :: AForm WebApp WebApp S3Creds
|
||||
s3CredsAForm = S3Creds
|
||||
<$> areq textField "Access Key ID" Nothing
|
||||
<*> areq passwordField "Secret Access Key" Nothing
|
||||
|
||||
getAddS3R :: Handler RepHtml
|
||||
getAddS3R = s3Configurator $ do
|
||||
((result, form), enctype) <- lift $
|
||||
runFormGet $ renderBootstrap s3InputAForm
|
||||
case result of
|
||||
FormSuccess s3input -> lift $ do
|
||||
let name = T.unpack $ repoName s3input
|
||||
makeS3Remote (extractCreds s3input) name setgroup $ M.fromList
|
||||
[ ("encryption", "shared")
|
||||
, ("type", "S3")
|
||||
, ("datacenter", T.unpack $ datacenter s3input)
|
||||
, ("storageclass", show $ storageClass s3input)
|
||||
]
|
||||
_ -> do
|
||||
let authtoken = webAppFormAuthToken
|
||||
$(widgetFile "configurators/adds3")
|
||||
where
|
||||
setgroup r = runAnnex () $
|
||||
setStandardGroup (Remote.uuid r) TransferGroup
|
||||
|
||||
getEnableS3R :: UUID -> Handler RepHtml
|
||||
getEnableS3R uuid = s3Configurator $ do
|
||||
((result, form), enctype) <- lift $
|
||||
runFormGet $ renderBootstrap s3CredsAForm
|
||||
case result of
|
||||
FormSuccess s3creds -> lift $ do
|
||||
m <- runAnnex M.empty readRemoteLog
|
||||
let name = fromJust $ M.lookup "name" $
|
||||
fromJust $ M.lookup uuid m
|
||||
makeS3Remote s3creds name (const noop) M.empty
|
||||
_ -> do
|
||||
let authtoken = webAppFormAuthToken
|
||||
description <- lift $ runAnnex "" $
|
||||
T.pack . concat <$> Remote.prettyListUUIDs [uuid]
|
||||
$(widgetFile "configurators/enables3")
|
||||
|
||||
makeS3Remote :: S3Creds -> String -> (Remote -> Handler ()) -> RemoteConfig -> Handler ()
|
||||
makeS3Remote (S3Creds ak sk) name setup config = do
|
||||
remotename <- runAnnex name $ fromRepo $ uniqueRemoteName name 0
|
||||
liftIO $ AWS.setCredsEnv (T.unpack ak, T.unpack sk)
|
||||
r <- liftAssistant $ liftAnnex $ addRemote $ do
|
||||
makeSpecialRemote name S3.remote config
|
||||
return remotename
|
||||
setup r
|
||||
liftAssistant $ syncNewRemote r
|
||||
redirect $ EditNewCloudRepositoryR $ Remote.uuid r
|
||||
|
|
@ -25,6 +25,7 @@
|
|||
/config/repository/add/ssh/make/rsync/#SshData MakeSshRsyncR GET
|
||||
/config/repository/add/cloud/rsync.net AddRsyncNetR GET
|
||||
/config/repository/add/cloud/S3 AddS3R GET
|
||||
/config/repository/add/cloud/glacier AddGlacierR GET
|
||||
/config/repository/add/cloud/box.com AddBoxComR GET
|
||||
|
||||
/config/repository/pair/local/start StartLocalPairR GET
|
||||
|
|
@ -38,6 +39,7 @@
|
|||
/config/repository/enable/rsync/#UUID EnableRsyncR GET
|
||||
/config/repository/enable/directory/#UUID EnableDirectoryR GET
|
||||
/config/repository/enable/S3/#UUID EnableS3R GET
|
||||
/config/repository/enable/glacier/#UUID EnableGlacierR GET
|
||||
/config/repository/enable/webdav/#UUID EnableWebDAVR GET
|
||||
|
||||
/transfers/#NotificationId TransfersR GET
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue