Skip to content

Commit 376342e

Browse files
snoybergsnoyberg
committed
Simplify Stack.Upload API
1 parent aaecb6a commit 376342e

File tree

2 files changed

+83
-211
lines changed

2 files changed

+83
-211
lines changed

‎src/Stack/Upload.hs‎

Lines changed: 75 additions & 203 deletions
Original file line numberDiff line numberDiff line change
@@ -1,37 +1,23 @@
11
{-# LANGUAGE DeriveDataTypeable #-}
2+
{-# LANGUAGE FlexibleContexts #-}
3+
{-# LANGUAGE FlexibleInstances #-}
24
{-# LANGUAGE OverloadedStrings #-}
35
{-# LANGUAGE ScopedTypeVariables #-}
46
-- | Provide ability to upload tarballs to Hackage.
57
module Stack.Upload
68
( -- * Upload
7-
nopUploader
8-
, mkUploader
9-
, Uploader
10-
, upload
9+
upload
1110
, uploadBytes
1211
, uploadRevision
13-
, UploadSettings
14-
, defaultUploadSettings
15-
, setUploadUrl
16-
, setCredsSource
17-
, setSaveCreds
1812
-- * Credentials
1913
, HackageCreds
2014
, loadCreds
21-
, saveCreds
22-
, FromFile
23-
-- ** Credentials source
24-
, HackageCredsSource
25-
, fromAnywhere
26-
, fromPrompt
27-
, fromFile
28-
, fromMemory
2915
) where
3016

3117
import Control.Applicative
32-
import Control.Exception (bracket)
18+
import Control.Exception.Safe (bracket, handleIO)
3319
import qualified Control.Exception as E
34-
import Control.Monad (when, void)
20+
import Control.Monad (void)
3521
import Data.Aeson (FromJSON (..),
3622
ToJSON (..),
3723
eitherDecode', encode,
@@ -79,104 +65,62 @@ import System.IO (hFlush, hGetEcho, hSetEc
7965
data HackageCreds = HackageCreds
8066
{ hcUsername :: !Text
8167
, hcPassword :: !Text
68+
, hcCredsFile :: !FilePath
8269
}
8370
deriving Show
8471

8572
instance ToJSON HackageCreds where
86-
toJSON (HackageCreds u p) = object
73+
toJSON (HackageCreds u p _) = object
8774
[ "username" .= u
8875
, "password" .= p
8976
]
90-
instance FromJSON HackageCreds where
77+
instance FromJSON (FilePath -> HackageCreds) where
9178
parseJSON = withObject "HackageCreds" $ \o -> HackageCreds
9279
<$> o .: "username"
9380
<*> o .: "password"
9481

95-
-- | A source for getting Hackage credentials.
82+
-- | Load Hackage credentials, either from a save file or the command
83+
-- line.
9684
--
9785
-- Since 0.1.0.0
98-
newtype HackageCredsSource = HackageCredsSource
99-
{ getCreds :: IO (HackageCreds, FromFile)
100-
}
101-
102-
-- | Whether the Hackage credentials were loaded from a file.
103-
--
104-
-- This information is useful since, typically, you only want to save the
105-
-- credentials to a file if it wasn't already loaded from there.
106-
--
107-
-- Since 0.1.0.0
108-
type FromFile = Bool
109-
110-
-- | Load Hackage credentials from the given source.
111-
--
112-
-- Since 0.1.0.0
113-
loadCreds :: HackageCredsSource -> IO (HackageCreds, FromFile)
114-
loadCreds = getCreds
115-
116-
-- | Save the given credentials to the credentials file.
117-
--
118-
-- Since 0.1.0.0
119-
saveCreds :: Config -> HackageCreds -> IO ()
120-
saveCreds config creds = do
121-
fp <- credsFile config
122-
L.writeFile fp $ encode creds
123-
124-
-- | Load the Hackage credentials from the prompt, asking the user to type them
125-
-- in.
126-
--
127-
-- Since 0.1.0.0
128-
fromPrompt :: HackageCredsSource
129-
fromPrompt = HackageCredsSource $ do
130-
putStr "Hackage username: "
131-
hFlush stdout
132-
username <- TIO.getLine
133-
password <- promptPassword
134-
return (HackageCreds
135-
{ hcUsername = username
136-
, hcPassword = password
137-
}, False)
86+
loadCreds :: Config -> IO HackageCreds
87+
loadCreds config = do
88+
fp <- credsFile config
89+
fromFile fp `E.catches`
90+
[ E.Handler $ \(_ :: E.IOException) -> fromPrompt fp
91+
, E.Handler $ \(_ :: HackageCredsExceptions) -> fromPrompt fp
92+
]
93+
where
94+
fromFile fp = do
95+
lbs <- L.readFile fp
96+
either
97+
(E.throwIO . Couldn'tParseJSON fp)
98+
(return . ($ fp))
99+
(eitherDecode' lbs)
100+
101+
fromPrompt fp = do
102+
putStr "Hackage username: "
103+
hFlush stdout
104+
username <- TIO.getLine
105+
password <- promptPassword
106+
let hc = HackageCreds
107+
{ hcUsername = username
108+
, hcPassword = password
109+
, hcCredsFile = fp
110+
}
111+
L.writeFile fp (encode hc)
112+
return hc
138113

139114
credsFile :: Config -> IO FilePath
140115
credsFile config = do
141116
let dir = toFilePath (configStackRoot config) </> "upload"
142117
createDirectoryIfMissing True dir
143118
return $ dir </> "credentials.json"
144119

145-
-- | Load the Hackage credentials from the JSON config file.
146-
--
147-
-- Since 0.1.0.0
148-
fromFile :: Config -> HackageCredsSource
149-
fromFile config = HackageCredsSource $ do
150-
fp <- credsFile config
151-
lbs <- L.readFile fp
152-
case eitherDecode' lbs of
153-
Left e -> E.throwIO $ Couldn'tParseJSON fp e
154-
Right creds -> return (creds, True)
155-
156-
-- | Load the Hackage credentials from the given arguments.
157-
--
158-
-- Since 0.1.0.0
159-
fromMemory :: Text -> Text -> HackageCredsSource
160-
fromMemory u p = HackageCredsSource $ return (HackageCreds
161-
{ hcUsername = u
162-
, hcPassword = p
163-
}, False)
164-
165120
data HackageCredsExceptions = Couldn'tParseJSON FilePath String
166121
deriving (Show, Typeable)
167122
instance E.Exception HackageCredsExceptions
168123

169-
-- | Try to load the credentials from the config file. If that fails, ask the
170-
-- user to enter them.
171-
--
172-
-- Since 0.1.0.0
173-
fromAnywhere :: Config -> HackageCredsSource
174-
fromAnywhere config = HackageCredsSource $
175-
getCreds (fromFile config) `E.catches`
176-
[ E.Handler $ \(_ :: E.IOException) -> getCreds fromPrompt
177-
, E.Handler $ \(_ :: HackageCredsExceptions) -> getCreds fromPrompt
178-
]
179-
180124
-- | Lifted from cabal-install, Distribution.Client.Upload
181125
promptPassword :: IO Text
182126
promptPassword = do
@@ -189,11 +133,6 @@ promptPassword = do
189133
putStrLn ""
190134
return passwd
191135

192-
nopUploader :: Config -> UploadSettings -> IO Uploader
193-
nopUploader _ _ = return (Uploader nop)
194-
where nop :: String -> L.ByteString -> IO HackageCreds
195-
nop _ _ = return (HackageCreds "nopUploader" "")
196-
197136
applyCreds :: HackageCreds -> Request -> IO Request
198137
applyCreds creds req0 = do
199138
manager <- getGlobalManager
@@ -211,71 +150,52 @@ applyCreds creds req0 = do
211150
return req0
212151
Right req -> return req
213152

214-
-- | Turn the given settings into an @Uploader@.
153+
-- | Upload a single tarball with the given @Uploader@. Instead of
154+
-- sending a file like 'upload', this sends a lazy bytestring.
215155
--
216-
-- Since 0.1.0.0
217-
mkUploader :: Config -> UploadSettings -> IO Uploader
218-
mkUploader config us = do
219-
(creds, fromFile') <- loadCreds $ usCredsSource us config
220-
when (not fromFile' && usSaveCreds us) $ saveCreds config creds
221-
req0 <- parseRequest $ usUploadUrl us
222-
let req1 = setRequestHeader "Accept" ["text/plain"] req0
223-
return Uploader
224-
{ upload_ = \tarName bytes -> do
225-
let formData = [partFileRequestBody "package" tarName (RequestBodyLBS bytes)]
226-
req2 <- formDataBody formData req1
227-
req3 <- applyCreds creds req2
228-
putStr $ "Uploading " ++ tarName ++ "... "
229-
hFlush stdout
230-
withResponse req3 $ \res ->
231-
case getResponseStatusCode res of
232-
200 -> putStrLn "done!"
233-
401 -> do
234-
putStrLn "authentication failure"
235-
cfp <- credsFile config
236-
handleIO (const $ return ()) (removeFile cfp)
237-
throwString "Authentication failure uploading to server"
238-
403 -> do
239-
putStrLn "forbidden upload"
240-
putStrLn "Usually means: you've already uploaded this package/version combination"
241-
putStrLn "Ignoring error and continuing, full message from Hackage below:\n"
242-
printBody res
243-
503 -> do
244-
putStrLn "service unavailable"
245-
putStrLn "This error some times gets sent even though the upload succeeded"
246-
putStrLn "Check on Hackage to see if your pacakge is present"
247-
printBody res
248-
code -> do
249-
putStrLn $ "unhandled status code: " ++ show code
250-
printBody res
251-
throwString $ "Upload failed on " ++ tarName
252-
return creds
253-
}
156+
-- Since 0.1.2.1
157+
uploadBytes :: HackageCreds
158+
-> String -- ^ tar file name
159+
-> L.ByteString -- ^ tar file contents
160+
-> IO ()
161+
uploadBytes creds tarName bytes = do
162+
let req1 = setRequestHeader "Accept" ["text/plain"]
163+
"https://hackage.haskell.org/packages/"
164+
formData = [partFileRequestBody "package" tarName (RequestBodyLBS bytes)]
165+
req2 <- formDataBody formData req1
166+
req3 <- applyCreds creds req2
167+
putStr $ "Uploading " ++ tarName ++ "... "
168+
hFlush stdout
169+
withResponse req3 $ \res ->
170+
case getResponseStatusCode res of
171+
200 -> putStrLn "done!"
172+
401 -> do
173+
putStrLn "authentication failure"
174+
handleIO (const $ return ()) (removeFile (hcCredsFile creds))
175+
throwString "Authentication failure uploading to server"
176+
403 -> do
177+
putStrLn "forbidden upload"
178+
putStrLn "Usually means: you've already uploaded this package/version combination"
179+
putStrLn "Ignoring error and continuing, full message from Hackage below:\n"
180+
printBody res
181+
503 -> do
182+
putStrLn "service unavailable"
183+
putStrLn "This error some times gets sent even though the upload succeeded"
184+
putStrLn "Check on Hackage to see if your pacakge is present"
185+
printBody res
186+
code -> do
187+
putStrLn $ "unhandled status code: " ++ show code
188+
printBody res
189+
throwString $ "Upload failed on " ++ tarName
254190

255191
printBody :: Response (ConduitM () S.ByteString IO ()) -> IO ()
256192
printBody res = runConduit $ getResponseBody res .| CB.sinkHandle stdout
257193

258-
-- | The computed value from a @UploadSettings@.
259-
--
260-
-- Typically, you want to use this with 'upload'.
261-
--
262-
-- Since 0.1.0.0
263-
newtype Uploader = Uploader
264-
{ upload_ :: String -> L.ByteString -> IO HackageCreds
265-
}
266-
267194
-- | Upload a single tarball with the given @Uploader@.
268195
--
269196
-- Since 0.1.0.0
270-
upload :: Uploader -> FilePath -> IO HackageCreds
271-
upload uploader fp = upload_ uploader (takeFileName fp) =<< L.readFile fp
272-
273-
-- | Upload a single tarball with the given @Uploader@. Instead of
274-
-- sending a file like 'upload', this sends a lazy bytestring.
275-
--
276-
-- Since 0.1.2.1
277-
uploadBytes :: Uploader -> String -> L.ByteString -> IO HackageCreds
278-
uploadBytes = upload_
197+
upload :: HackageCreds -> FilePath -> IO ()
198+
upload creds fp = uploadBytes creds (takeFileName fp) =<< L.readFile fp
279199

280200
uploadRevision :: HackageCreds
281201
-> PackageIdentifier
@@ -296,51 +216,3 @@ uploadRevision creds ident cabalFile = do
296216
req0
297217
req2 <- applyCreds creds req1
298218
void $ httpNoBody req2
299-
300-
-- | Settings for creating an @Uploader@.
301-
--
302-
-- Since 0.1.0.0
303-
data UploadSettings = UploadSettings
304-
{ usUploadUrl :: !String
305-
, usCredsSource :: !(Config -> HackageCredsSource)
306-
, usSaveCreds :: !Bool
307-
}
308-
309-
-- | Default value for @UploadSettings@.
310-
--
311-
-- Use setter functions to change defaults.
312-
--
313-
-- Since 0.1.0.0
314-
defaultUploadSettings :: UploadSettings
315-
defaultUploadSettings = UploadSettings
316-
{ usUploadUrl = "https://hackage.haskell.org/packages/"
317-
, usCredsSource = fromAnywhere
318-
, usSaveCreds = True
319-
}
320-
321-
-- | Change the upload URL.
322-
--
323-
-- Default: "https://hackage.haskell.org/packages/"
324-
--
325-
-- Since 0.1.0.0
326-
setUploadUrl :: String -> UploadSettings -> UploadSettings
327-
setUploadUrl x us = us { usUploadUrl = x }
328-
329-
-- | How to get the Hackage credentials.
330-
--
331-
-- Default: @fromAnywhere@
332-
--
333-
-- Since 0.1.0.0
334-
setCredsSource :: (Config -> HackageCredsSource) -> UploadSettings -> UploadSettings
335-
setCredsSource x us = us { usCredsSource = x }
336-
337-
-- | Save new credentials to the config file.
338-
--
339-
-- Default: @True@
340-
--
341-
-- Since 0.1.0.0
342-
setSaveCreds :: Bool -> UploadSettings -> UploadSettings
343-
setSaveCreds x us = us { usSaveCreds = x }
344-
345-
handleIO :: (E.IOException -> IO a) -> IO a -> IO a
346-
handleIO = E.handle

‎src/main/Main.hs‎

Lines changed: 8 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -25,6 +25,7 @@ import Control.Monad.Writer.Lazy (Writer)
2525
import Data.Attoparsec.Args (parseArgs, EscapingMode (Escaping))
2626
import Data.Attoparsec.Interpreter (getInterpreterArgs)
2727
import qualified Data.ByteString.Lazy as L
28+
import Data.IORef.RunOnce (runOnce)
2829
import Data.List
2930
import qualified Data.Map as Map
3031
import Data.Maybe
@@ -686,20 +687,18 @@ uploadCmd (args, mpvpBounds, ignoreCheck, don'tSign, sigServerUrl) go = do
686687
"Error: stack upload expects a list sdist tarballs or cabal directories. Can't find " ++
687688
show invalid
688689
exitFailure
689-
let getUploader :: (HasConfig config) => StackT config IO Upload.Uploader
690-
getUploader = do
691-
config <- view configL
692-
liftIO $ Upload.mkUploader config Upload.defaultUploadSettings
693690
withBuildConfigAndLock go $ \_ -> do
694-
uploader <- getUploader
691+
config <- view configL
692+
getCreds <- liftIO (runOnce (Upload.loadCreds config))
695693
unless ignoreCheck $
696694
mapM_ (resolveFile' >=> checkSDistTarball) files
697695
forM_
698696
files
699697
(\file ->
700698
do tarFile <- resolveFile' file
701-
liftIO
702-
(void (Upload.upload uploader (toFilePath tarFile)))
699+
liftIO $ do
700+
creds <- getCreds
701+
Upload.upload creds (toFilePath tarFile)
703702
unless
704703
don'tSign
705704
(void $
@@ -712,7 +711,8 @@ uploadCmd (args, mpvpBounds, ignoreCheck, don'tSign, sigServerUrl) go = do
712711
(tarName, tarBytes, mcabalRevision) <- getSDistTarball mpvpBounds pkgDir
713712
unless ignoreCheck $ checkSDistTarball' tarName tarBytes
714713
liftIO $ do
715-
creds <- Upload.uploadBytes uploader tarName tarBytes
714+
creds <- getCreds
715+
Upload.uploadBytes creds tarName tarBytes
716716
forM_ mcabalRevision $ uncurry $ Upload.uploadRevision creds
717717
tarPath <- parseRelFile tarName
718718
unless

0 commit comments

Comments
 (0)