1{- git-annex assistant webapp configurators for Internet Archive 2 - 3 - Copyright 2013 Joey Hess <id@joeyh.name> 4 - 5 - Licensed under the GNU AGPL version 3 or higher. 6 -} 7 8{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-} 9 10module Assistant.WebApp.Configurators.IA where 11 12import Assistant.WebApp.Common 13import qualified Assistant.WebApp.Configurators.AWS as AWS 14import qualified Remote.S3 as S3 15import qualified Remote.Helper.AWS as AWS 16import Assistant.WebApp.MakeRemote 17import qualified Remote 18import qualified Types.Remote as Remote 19import Types.StandardGroups 20import Logs.Remote 21import Assistant.Gpg 22import Types.Remote (RemoteConfig) 23import qualified Annex.Url as Url 24import Creds 25import Annex.SpecialRemote.Config 26import Types.ProposedAccepted 27 28import qualified Data.Text as T 29import qualified Data.Map as M 30import Data.Char 31import Network.URI 32 33iaConfigurator :: Widget -> Handler Html 34iaConfigurator = page "Add an Internet Archive repository" (Just Configuration) 35 36data IAInput = IAInput 37 { accessKeyID :: Text 38 , secretAccessKey :: Text 39 , mediaType :: MediaType 40 , itemName :: Text 41 } 42 43extractCreds :: IAInput -> AWS.AWSCreds 44extractCreds i = AWS.AWSCreds (accessKeyID i) (secretAccessKey i) 45 46{- IA defines only a few media types currently, or the media type 47 - may be omitted 48 - 49 - We add a few other common types, mapped to what we've been told 50 - is the closest match. 51 -} 52data MediaType = MediaImages | MediaAudio | MediaVideo | MediaText | MediaSoftware | MediaOmitted 53 deriving (Eq, Ord, Enum, Bounded) 54 55{- Format a MediaType for entry into the IA metadata -} 56formatMediaType :: MediaType -> String 57formatMediaType MediaText = "texts" 58formatMediaType MediaImages = "image" 59formatMediaType MediaSoftware = "software" 60formatMediaType MediaVideo = "movies" 61formatMediaType MediaAudio = "audio" 62formatMediaType MediaOmitted = "" 63 64{- A default collection to use for each Mediatype. -} 65collectionMediaType :: MediaType -> Maybe String 66collectionMediaType MediaText = Just "opensource" 67collectionMediaType MediaImages = Just "opensource" -- not ideal 68collectionMediaType MediaSoftware = Just "opensource" -- not ideal 69collectionMediaType MediaVideo = Just "opensource_movies" 70collectionMediaType MediaAudio = Just "opensource_audio" 71collectionMediaType MediaOmitted = Just "opensource" 72 73{- Format a MediaType for user display. -} 74showMediaType :: MediaType -> String 75showMediaType MediaText = "texts" 76showMediaType MediaImages = "photos & images" 77showMediaType MediaSoftware = "software" 78showMediaType MediaVideo = "videos & movies" 79showMediaType MediaAudio = "audio & music" 80showMediaType MediaOmitted = "other" 81 82iaInputAForm :: Maybe CredPair -> MkAForm IAInput 83iaInputAForm defcreds = IAInput 84 <$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds) 85 <*> AWS.secretAccessKeyField (T.pack . snd <$> defcreds) 86 <*> areq (selectFieldList mediatypes) (bfs "Media Type") (Just MediaOmitted) 87 <*> areq (textField `withExpandableNote` ("Help", itemNameHelp)) (bfs "Item Name") Nothing 88 where 89 mediatypes :: [(Text, MediaType)] 90 mediatypes = map (\t -> (T.pack $ showMediaType t, t)) [minBound..] 91 92itemNameHelp :: Widget 93itemNameHelp = [whamlet| 94<div> 95 Each item stored in the Internet Archive must have a unique name. 96<div> 97 Once you create the item, a special directory will appear # 98 with a name matching the item name. Files you put in that directory # 99 will be uploaded to your Internet Archive item. 100|] 101 102iaCredsAForm :: Maybe CredPair -> MkAForm AWS.AWSCreds 103iaCredsAForm defcreds = AWS.AWSCreds 104 <$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds) 105 <*> AWS.secretAccessKeyField (T.pack . snd <$> defcreds) 106 107previouslyUsedIACreds :: Annex (Maybe CredPair) 108previouslyUsedIACreds = previouslyUsedCredPair AWS.creds S3.remote $ 109 S3.configIA . Remote.config 110 111accessKeyIDFieldWithHelp :: Maybe Text -> MkAForm Text 112accessKeyIDFieldWithHelp = AWS.accessKeyIDField help 113 where 114 help = [whamlet| 115<a href="http://archive.org/account/s3.php"> 116 Get Internet Archive access keys 117|] 118 119getAddIAR :: Handler Html 120getAddIAR = postAddIAR 121 122postAddIAR :: Handler Html 123postAddIAR = iaConfigurator $ do 124 defcreds <- liftAnnex previouslyUsedIACreds 125 ((result, form), enctype) <- liftH $ 126 runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ iaInputAForm defcreds 127 case result of 128 FormSuccess input -> liftH $ do 129 let name = escapeBucket $ T.unpack $ itemName input 130 let wrap (k, v) = (Proposed k, Proposed v) 131 let c = map wrap $ catMaybes 132 [ Just ("type", "S3") 133 , Just ("host", S3.iaHost) 134 , Just ("bucket", escapeHeader name) 135 , Just ("x-archive-meta-title", escapeHeader $ T.unpack $ itemName input) 136 , if mediaType input == MediaOmitted 137 then Nothing 138 else Just ("x-archive-mediatype", formatMediaType $ mediaType input) 139 , (,) <$> pure "x-archive-meta-collection" <*> collectionMediaType (mediaType input) 140 -- Make item show up ASAP. 141 , Just ("x-archive-interactive-priority", "1") 142 , Just ("preferreddir", name) 143 ] 144 AWS.makeAWSRemote initSpecialRemote S3.remote PublicGroup (extractCreds input) name $ 145 M.fromList $ configureEncryption NoEncryption : c 146 _ -> $(widgetFile "configurators/addia") 147 148getEnableIAR :: UUID -> Handler Html 149getEnableIAR = postEnableIAR 150 151postEnableIAR :: UUID -> Handler Html 152postEnableIAR = iaConfigurator . enableIARemote 153 154enableIARemote :: UUID -> Widget 155enableIARemote uuid = do 156 defcreds <- liftAnnex previouslyUsedIACreds 157 ((result, form), enctype) <- liftH $ 158 runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ iaCredsAForm defcreds 159 case result of 160 FormSuccess creds -> liftH $ do 161 m <- liftAnnex remoteConfigMap 162 let name = fromJust $ lookupName $ 163 fromJust $ M.lookup uuid m 164 AWS.makeAWSRemote enableSpecialRemote S3.remote PublicGroup creds name M.empty 165 _ -> do 166 description <- liftAnnex $ 167 T.pack <$> Remote.prettyUUID uuid 168 $(widgetFile "configurators/enableia") 169 170{- Convert a description into a bucket item name, which will also be 171 - used as the repository name, and the preferreddir. 172 - IA seems to need only lower case, and no spaces. -} 173escapeBucket :: String -> String 174escapeBucket = map toLower . replace " " "-" 175 176{- IA S3 API likes headers to be URI escaped, escaping spaces looks ugly. -} 177escapeHeader :: String -> String 178escapeHeader = escapeURIString (\c -> isUnescapedInURI c && c /= ' ') 179 180getRepoInfo :: RemoteConfig -> Widget 181getRepoInfo c = do 182 uo <- liftAnnex Url.getUrlOptions 183 exists <- liftAnnex $ catchDefaultIO False $ Url.exists url uo 184 [whamlet| 185<a href="#{url}"> 186 Internet Archive item 187$if (not exists) 188 <p> 189 The page will only be available once some files # 190 have been uploaded, and the Internet Archive has processed them. 191|] 192 where 193 bucket = maybe "" fromProposedAccepted $ M.lookup (Accepted "bucket") c 194 url = S3.iaItemUrl bucket 195