6ea511beb4
So these special remotes are always supported. IIRC these build flags were added because the dep chains were a bit too long, or perhaps because the libraries were not available in Debian stable, or something like that. That was long ago, those reasons no longer apply, and users get confused when builtin special remotes are not available, so it seems best to remove the build flags now. If this does cause a problem it can be reverted of course.. This commit was sponsored by Jochen Bartl on Patreon.
194 lines
6.7 KiB
Haskell
194 lines
6.7 KiB
Haskell
{- git-annex assistant webapp configurators for Internet Archive
|
|
-
|
|
- Copyright 2013 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
|
|
|
|
module Assistant.WebApp.Configurators.IA where
|
|
|
|
import Assistant.WebApp.Common
|
|
import qualified Assistant.WebApp.Configurators.AWS as AWS
|
|
import qualified Remote.S3 as S3
|
|
import qualified Remote.Helper.AWS as AWS
|
|
import Assistant.WebApp.MakeRemote
|
|
import qualified Remote
|
|
import qualified Types.Remote as Remote
|
|
import Types.StandardGroups
|
|
import Logs.Remote
|
|
import Assistant.Gpg
|
|
import Types.Remote (RemoteConfig)
|
|
import qualified Annex.Url as Url
|
|
import Creds
|
|
import Annex.SpecialRemote.Config
|
|
import Types.ProposedAccepted
|
|
|
|
import qualified Data.Text as T
|
|
import qualified Data.Map as M
|
|
import Data.Char
|
|
import Network.URI
|
|
|
|
iaConfigurator :: Widget -> Handler Html
|
|
iaConfigurator = page "Add an Internet Archive repository" (Just Configuration)
|
|
|
|
data IAInput = IAInput
|
|
{ accessKeyID :: Text
|
|
, secretAccessKey :: Text
|
|
, mediaType :: MediaType
|
|
, itemName :: Text
|
|
}
|
|
|
|
extractCreds :: IAInput -> AWS.AWSCreds
|
|
extractCreds i = AWS.AWSCreds (accessKeyID i) (secretAccessKey i)
|
|
|
|
{- IA defines only a few media types currently, or the media type
|
|
- may be omitted
|
|
-
|
|
- We add a few other common types, mapped to what we've been told
|
|
- is the closest match.
|
|
-}
|
|
data MediaType = MediaImages | MediaAudio | MediaVideo | MediaText | MediaSoftware | MediaOmitted
|
|
deriving (Eq, Ord, Enum, Bounded)
|
|
|
|
{- Format a MediaType for entry into the IA metadata -}
|
|
formatMediaType :: MediaType -> String
|
|
formatMediaType MediaText = "texts"
|
|
formatMediaType MediaImages = "image"
|
|
formatMediaType MediaSoftware = "software"
|
|
formatMediaType MediaVideo = "movies"
|
|
formatMediaType MediaAudio = "audio"
|
|
formatMediaType MediaOmitted = ""
|
|
|
|
{- A default collection to use for each Mediatype. -}
|
|
collectionMediaType :: MediaType -> Maybe String
|
|
collectionMediaType MediaText = Just "opensource"
|
|
collectionMediaType MediaImages = Just "opensource" -- not ideal
|
|
collectionMediaType MediaSoftware = Just "opensource" -- not ideal
|
|
collectionMediaType MediaVideo = Just "opensource_movies"
|
|
collectionMediaType MediaAudio = Just "opensource_audio"
|
|
collectionMediaType MediaOmitted = Just "opensource"
|
|
|
|
{- Format a MediaType for user display. -}
|
|
showMediaType :: MediaType -> String
|
|
showMediaType MediaText = "texts"
|
|
showMediaType MediaImages = "photos & images"
|
|
showMediaType MediaSoftware = "software"
|
|
showMediaType MediaVideo = "videos & movies"
|
|
showMediaType MediaAudio = "audio & music"
|
|
showMediaType MediaOmitted = "other"
|
|
|
|
iaInputAForm :: Maybe CredPair -> MkAForm IAInput
|
|
iaInputAForm defcreds = IAInput
|
|
<$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
|
|
<*> AWS.secretAccessKeyField (T.pack . snd <$> defcreds)
|
|
<*> areq (selectFieldList mediatypes) (bfs "Media Type") (Just MediaOmitted)
|
|
<*> areq (textField `withExpandableNote` ("Help", itemNameHelp)) (bfs "Item Name") Nothing
|
|
where
|
|
mediatypes :: [(Text, MediaType)]
|
|
mediatypes = map (\t -> (T.pack $ showMediaType t, t)) [minBound..]
|
|
|
|
itemNameHelp :: Widget
|
|
itemNameHelp = [whamlet|
|
|
<div>
|
|
Each item stored in the Internet Archive must have a unique name.
|
|
<div>
|
|
Once you create the item, a special directory will appear #
|
|
with a name matching the item name. Files you put in that directory #
|
|
will be uploaded to your Internet Archive item.
|
|
|]
|
|
|
|
iaCredsAForm :: Maybe CredPair -> MkAForm AWS.AWSCreds
|
|
iaCredsAForm defcreds = AWS.AWSCreds
|
|
<$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
|
|
<*> AWS.secretAccessKeyField (T.pack . snd <$> defcreds)
|
|
|
|
previouslyUsedIACreds :: Annex (Maybe CredPair)
|
|
previouslyUsedIACreds = previouslyUsedCredPair AWS.creds S3.remote $
|
|
S3.configIA . Remote.config
|
|
|
|
accessKeyIDFieldWithHelp :: Maybe Text -> MkAForm Text
|
|
accessKeyIDFieldWithHelp = AWS.accessKeyIDField help
|
|
where
|
|
help = [whamlet|
|
|
<a href="http://archive.org/account/s3.php">
|
|
Get Internet Archive access keys
|
|
|]
|
|
|
|
getAddIAR :: Handler Html
|
|
getAddIAR = postAddIAR
|
|
|
|
postAddIAR :: Handler Html
|
|
postAddIAR = iaConfigurator $ do
|
|
defcreds <- liftAnnex previouslyUsedIACreds
|
|
((result, form), enctype) <- liftH $
|
|
runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ iaInputAForm defcreds
|
|
case result of
|
|
FormSuccess input -> liftH $ do
|
|
let name = escapeBucket $ T.unpack $ itemName input
|
|
let wrap (k, v) = (Proposed k, Proposed v)
|
|
let c = map wrap $ catMaybes
|
|
[ Just ("type", "S3")
|
|
, Just ("host", S3.iaHost)
|
|
, Just ("bucket", escapeHeader name)
|
|
, Just ("x-archive-meta-title", escapeHeader $ T.unpack $ itemName input)
|
|
, if mediaType input == MediaOmitted
|
|
then Nothing
|
|
else Just ("x-archive-mediatype", formatMediaType $ mediaType input)
|
|
, (,) <$> pure "x-archive-meta-collection" <*> collectionMediaType (mediaType input)
|
|
-- Make item show up ASAP.
|
|
, Just ("x-archive-interactive-priority", "1")
|
|
, Just ("preferreddir", name)
|
|
]
|
|
AWS.makeAWSRemote initSpecialRemote S3.remote PublicGroup (extractCreds input) name $
|
|
M.fromList $ configureEncryption NoEncryption : c
|
|
_ -> $(widgetFile "configurators/addia")
|
|
|
|
getEnableIAR :: UUID -> Handler Html
|
|
getEnableIAR = postEnableIAR
|
|
|
|
postEnableIAR :: UUID -> Handler Html
|
|
postEnableIAR = iaConfigurator . enableIARemote
|
|
|
|
enableIARemote :: UUID -> Widget
|
|
enableIARemote uuid = do
|
|
defcreds <- liftAnnex previouslyUsedIACreds
|
|
((result, form), enctype) <- liftH $
|
|
runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ iaCredsAForm defcreds
|
|
case result of
|
|
FormSuccess creds -> liftH $ do
|
|
m <- liftAnnex readRemoteLog
|
|
let name = fromJust $ lookupName $
|
|
fromJust $ M.lookup uuid m
|
|
AWS.makeAWSRemote enableSpecialRemote S3.remote PublicGroup creds name M.empty
|
|
_ -> do
|
|
description <- liftAnnex $
|
|
T.pack <$> Remote.prettyUUID uuid
|
|
$(widgetFile "configurators/enableia")
|
|
|
|
{- Convert a description into a bucket item name, which will also be
|
|
- used as the repository name, and the preferreddir.
|
|
- IA seems to need only lower case, and no spaces. -}
|
|
escapeBucket :: String -> String
|
|
escapeBucket = map toLower . replace " " "-"
|
|
|
|
{- IA S3 API likes headers to be URI escaped, escaping spaces looks ugly. -}
|
|
escapeHeader :: String -> String
|
|
escapeHeader = escapeURIString (\c -> isUnescapedInURI c && c /= ' ')
|
|
|
|
getRepoInfo :: RemoteConfig -> Widget
|
|
getRepoInfo c = do
|
|
uo <- liftAnnex Url.getUrlOptions
|
|
exists <- liftAnnex $ catchDefaultIO False $ Url.exists url uo
|
|
[whamlet|
|
|
<a href="#{url}">
|
|
Internet Archive item
|
|
$if (not exists)
|
|
<p>
|
|
The page will only be available once some files #
|
|
have been uploaded, and the Internet Archive has processed them.
|
|
|]
|
|
where
|
|
bucket = maybe "" fromProposedAccepted $ M.lookup (Accepted "bucket") c
|
|
url = S3.iaItemUrl bucket
|