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