1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
|
{- git-annex assistant webapp configurators for Internet Archive
-
- Copyright 2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE CPP, QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
module Assistant.WebApp.Configurators.IA where
import Assistant.WebApp.Common
import qualified Assistant.WebApp.Configurators.AWS as AWS
#ifdef WITH_S3
import qualified Remote.S3 as S3
import qualified Remote.Helper.AWS as AWS
import Assistant.WebApp.MakeRemote
#endif
import qualified Remote
import qualified Types.Remote as Remote
import Types.StandardGroups
import Types.Remote (RemoteConfig)
import Logs.Remote
import qualified Annex.Url as Url
import Creds
import Assistant.Gpg
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)
#ifdef WITH_S3
previouslyUsedIACreds :: Annex (Maybe CredPair)
previouslyUsedIACreds = previouslyUsedCredPair AWS.creds S3.remote $
S3.configIA . Remote.config
#endif
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
#ifdef WITH_S3
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
AWS.makeAWSRemote initSpecialRemote S3.remote PublicGroup (extractCreds input) name $
M.fromList $ catMaybes
[ Just $ configureEncryption NoEncryption
, 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)
]
_ -> $(widgetFile "configurators/addia")
#else
postAddIAR = error "S3 not supported by this build"
#endif
getEnableIAR :: UUID -> Handler Html
getEnableIAR = postEnableIAR
postEnableIAR :: UUID -> Handler Html
#ifdef WITH_S3
postEnableIAR = iaConfigurator . enableIARemote
#else
postEnableIAR _ = error "S3 not supported by this build"
#endif
#ifdef WITH_S3
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 $ M.lookup "name" $
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")
#endif
{- 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 <- liftIO $ catchDefaultIO False $ fst <$> 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 = fromMaybe "" $ M.lookup "bucket" c
#ifdef WITH_S3
url = S3.iaItemUrl bucket
#else
url = ""
#endif
|
