{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK prune #-}
{-# LANGUAGE CPP #-}
module Distribution.Hup.Upload (
module Distribution.Hup.Upload
, module Distribution.Hup.Types
, Auth(..)
)
where
import Control.Monad
import qualified Data.ByteString.Builder as Bu
import Data.List (dropWhileEnd)
import Data.Maybe (fromJust)
import Data.ByteString.Char8 (pack,unpack,putStrLn,ByteString(..) )
import qualified Data.ByteString.Lazy.Char8 as LBS
import qualified Data.ByteString.Lazy as L (ByteString)
import qualified Data.ByteString as BS
import Data.Monoid ( (<>) )
import qualified Network.HTTP.Client as C
import Network.HTTP.Client (requestHeaders, Request, RequestBody(..)
,method, requestBody, responseHeaders
,responseStatus)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import qualified Network.HTTP.Types as T
import Network.HTTP.Client.MultipartFormData
(formDataBody,partFileRequestBodyM
,Part)
import Distribution.Hup.Types
#if MIN_VERSION_http_client(0,4,30)
parseRequest = C.parseRequest
#else
parseRequest =
fmap noThrow . C.parseUrl
where
noThrow req = req { C.checkStatus = \_ _ _ -> Nothing }
#endif
type HResponse = C.Response
data Auth = Auth { authUser :: ByteString
, authPassword :: ByteString }
deriving (Eq, Show)
data Options = Options (Request -> Request)
defaultOptions :: Maybe Auth -> Options
defaultOptions mAuth =
case mAuth of
Nothing -> Options id
Just (Auth user pass) -> Options $ modify . C.applyBasicAuth user pass
where
modify :: Request -> Request
modify x = x {
requestHeaders = ("User-Agent", "haskell hup-0.1.0.0")
: ("Accept", "text/plain")
: requestHeaders x
}
mkAuth :: String -> String -> Maybe Auth
mkAuth name password =
Just $ Auth (pack name) (pack password)
getUploadUrl
:: String -> Upload -> String
getUploadUrl server upl =
let
serverUrl = dropWhileEnd (=='/') server
(Upload (Package pkgName pkgVer) _filePath _fileConts uploadType pkgType ) = upl
in case uploadType of
IsPackage -> case pkgType of
NormalPkg -> serverUrl <>"/packages/"
CandidatePkg -> serverUrl <>"/packages/candidates/"
IsDocumentation ->
case pkgType of
NormalPkg -> serverUrl <> "/package/" <> pkgName
<> "-" <> pkgVer <> "/docs"
CandidatePkg -> serverUrl <> "/package/" <> pkgName
<> "-" <> pkgVer
<> "/candidate/docs"
buildRequest :: String -> Upload -> Maybe Auth -> IO Request
buildRequest serverUrl upl userAuth =
let (Upload _ filePath fileConts uploadType _pkgType ) = upl
in case uploadType of
IsPackage -> do
let url = getUploadUrl serverUrl upl
postPkg url filePath fileConts userAuth
IsDocumentation -> do
let url = getUploadUrl serverUrl upl
putDocs url filePath fileConts userAuth
sendRequest
:: Request -> IO Response
sendRequest req = do
man <- C.newManager tlsManagerSettings
mkResponse <$> C.httpLbs req man
data Response =
Response {
statusCode :: Int
, message :: L.ByteString
, contentType :: L.ByteString
, responseBody :: L.ByteString
}
deriving Show
mkResponse :: HResponse L.ByteString -> Response
mkResponse resp =
let code = (T.statusCode . responseStatus) resp
mesg = LBS.fromStrict $ (T.statusMessage . responseStatus) resp
ctype = LBS.fromStrict $ fromJust $ lookup "Content-Type" $
responseHeaders resp
body = C.responseBody resp
in Response code mesg ctype body
postPkg
:: String -> FilePath -> Maybe L.ByteString -> Maybe Auth ->
IO Request
postPkg url fileName fileConts userAuth = do
let conts :: IO RequestBody
conts = RequestBodyLBS `liftM`
maybe (LBS.readFile fileName) return fileConts
(Options opt) = defaultOptions userAuth
formBody = formDataBody [partFileRequestBodyM "package" fileName conts]
opt <$> (formBody =<< parseRequest url)
putDocs :: String -> FilePath -> Maybe L.ByteString -> Maybe Auth -> IO Request
putDocs url fileName fileConts userAuth = do
conts <- maybe (LBS.readFile fileName) return fileConts
let (Options opt) = defaultOptions userAuth
addMore x = x {
method = "PUT"
, requestHeaders = ("Content-Type", "application/x-tar")
: ("Content-Encoding", "gzip")
: requestHeaders x
, requestBody = RequestBodyLBS conts
}
(addMore . opt) <$> parseRequest url
mkPart :: FilePath -> L.ByteString -> Part
mkPart fileName fileConts = do
let myConts = return $ RequestBodyLBS fileConts
partFileRequestBodyM "package" fileName myConts
bodyToByteString :: RequestBody -> L.ByteString
bodyToByteString b = case b of
RequestBodyLBS lbs -> lbs
RequestBodyBS bs -> Bu.toLazyByteString $ Bu.byteString bs
RequestBodyBuilder _sz builder -> Bu.toLazyByteString builder
_ -> error "bodyToBS not done yet"