{-# LANGUAGE OverloadedStrings #-}
-- |
-- Module: SHC.Lix
-- Copyright: (c) 2015 Michele Lacchia
-- License: ISC
-- Maintainer: Michele Lacchia <michelelacchia@gmail.com>
-- Stability: experimental
-- Portability: portable
--
-- Functions for sending data to Coveralls.io and reading results.
module SHC.Api (sendData, readCoverageResult)
where
import Codec.Binary.UTF8.String (decode)
import Data.Aeson (Value, encode)
import Data.Aeson.Lens (key, _Double, _String)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Text as T
import Control.Lens
import Network.HTTP.Client (RequestBody (RequestBodyLBS))
import Network.HTTP.Client.MultipartFormData (PartM, partFileRequestBody)
import Network.Wreq
import SHC.Types (Config (..),
PostResult (..))
-- | Send coverage JSON to Coveralls.io.
sendData :: Config -- ^ SHC configuration
-> String -- ^ URL
-> Value -- ^ The JSON object
-> IO PostResult
sendData conf url json = do
r <- postWith httpOptions url [partFileRequestBody "json_file" fileName requestBody :: PartM IO]
if r ^. responseStatus . statusCode == 200
then return $ readResponse r
else return . PostFailure $ formatResponseError r
where fileName = serviceName conf ++ "-" ++ jobId conf ++ ".json"
requestBody = RequestBodyLBS $ encode json
httpOptions = defaults & checkResponse ?~ noCheck
noCheck _ _ = return ()
readResponse :: Response LBS.ByteString -> PostResult
readResponse r =
case r ^? responseBody . key "error" . _String of
Just _ -> PostFailure $ formatResponseError r
Nothing -> case r ^? responseBody . key "url" . _String of
Just url -> PostSuccess $ T.unpack url
Nothing -> PostFailure "Error: malformed response body"
formatResponseError :: Response LBS.ByteString -> String
formatResponseError r =
"Coveralls returned HTTP " ++ show (r ^. responseStatus . statusCode) ++
" " ++ decode (BS.unpack $ r ^. responseStatus . statusMessage) ++ "\n" ++
decode (LBS.unpack $ r ^. responseBody)
-- | Read the coverage results from Coveralls.io.
readCoverageResult :: String -> IO (Maybe Double)
readCoverageResult url = do
r <- get url
return $ r ^? responseBody . key "covered_percent" . _Double