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 remoteConfigMap
|
|
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
|
|
urlexists <- liftAnnex $ catchDefaultIO False $ Url.exists url uo
|
|
[whamlet|
|
|
<a href="#{url}">
|
|
Internet Archive item
|
|
$if (not urlexists)
|
|
<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
|