{-# LANGUAGE OverloadedStrings #-}
module Distribution.Hup.Upload (
module Distribution.Hup.Upload
, module Distribution.Hup.Types
, Auth(..)
)
where
import Control.Exception (SomeException(..))
import Control.Lens
import Data.List (dropWhileEnd)
import Data.ByteString.Char8 (pack, unpack, putStrLn)
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy.Char8 as LC8
import qualified Data.ByteString.Lazy as BS
import Data.ByteString.Lazy ( ByteString(..))
import Data.Monoid ( (<>) )
import Network.Wreq as W hiding (Response, statusCode)
import qualified Network.Wreq as W
import Network.Wreq.Types hiding (auth,checkStatus,responseBody)
import Distribution.Hup.Types
import Distribution.Hup.Parse
type WResponse = W.Response
data Upload =
Upload { package :: Package
,fileToUpload :: FilePath
,uploadType :: IsDocumentation
,isCandidate :: IsCandidate
} deriving (Show, Eq)
defaultOptions :: Maybe Auth -> Options
defaultOptions maybeAuth = defaults
& header "Accept" .~ ["text/plain"]
& auth .~ maybeAuth
& checkStatus .~ (Just myHandler)
where
myHandler :: Status -> t1 -> t2 -> Maybe SomeException
myHandler status headers jar = Nothing
mkAuth name password =
Just $ BasicAuth (pack name) (pack password)
getUploadUrl
:: String -> Upload -> String
getUploadUrl server upl =
let
serverUrl = dropWhileEnd (=='/') $ server
(Upload (Package pkgName pkgVer) filePath 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"
upload
:: String -> Upload -> Maybe Auth -> IO (WResponse ByteString)
upload serverUrl upl userAuth =
let (Upload _ filePath uploadType _pkgType ) = upl
in case uploadType of
IsPackage ->
let url = getUploadUrl serverUrl upl
in postPkg url filePath userAuth
IsDocumentation ->
let url = getUploadUrl serverUrl upl
in putDocs url filePath userAuth
data Response =
Response {
statusCode :: Int
, message :: ByteString
, contentType :: ByteString
, responseBody :: ByteString
}
mkResponse :: WResponse ByteString -> Response
mkResponse resp =
let code = resp ^. responseStatus ^. W.statusCode
mesg = BS.fromStrict $ resp ^. responseStatus ^. statusMessage
ctype = BS.fromStrict $ resp ^. responseHeader "Content-Type"
body = resp ^. W.responseBody
in Response code mesg ctype body
postPkg
:: String -> FilePath -> Maybe Auth -> IO (WResponse ByteString)
postPkg url fileName userAuth =
let opts = defaultOptions userAuth
in postWith opts url (partFile "package" fileName)
putDocs
:: String
-> FilePath -> Maybe Auth -> IO (WResponse ByteString)
putDocs url fileName userAuth = do
let opts = defaultOptions userAuth
& header "Content-Type" .~ ["application/x-tar"]
& header "Content-Encoding" .~ ["gzip"]
conts <- BS.readFile fileName
putWith opts url conts
testUpload :: IO (WResponse ByteString)
testUpload = do
let
myServer = "http://localhost:8080"
myUser = "tmp"
myPassword = "tmp"
pkgName = "silly"
pkgVer = "0.1.0.0"
fileName = "../../silly-0.1.0.0-docs.tar.gz"
pkgType = CandidatePkg
uploadType = IsDocumentation
upl = Upload (Package pkgName pkgVer) fileName uploadType pkgType
auth = Just $ BasicAuth (pack myUser) (pack myPassword)
upload myServer upl auth