Post Request with Custom Header

submitpost.hs

import qualified Network.HTTP.Conduit as HTTP
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified Network.HTTP.Types.Header as HT
import Data.ByteString.Internal (unpackBytes)
import qualified Data.ByteString.Char8 as C
import GHC.Word (Word8)


testingGist = False

strToWord8s :: String -> [Word8]
strToWord8s = unpackBytes . C.pack 

submitPostRequest :: (MonadIO m, MonadBaseControl IO m) => String -> String -> String -> m BL.ByteString
submitPostRequest urlString githubKey body =
  case HTTP.parseUrl urlString of
    Nothing -> return $ "URL Syntax Error"
    Just initReq -> HTTP.withManager $ \manager -> do
        let customHeader = if testingGist then ("x-oauth-basic", "TEST!" ) else ("x-oauth-basic", (BS.pack (strToWord8s githubKey)) )
        let req = initReq { HTTP.secure = not testingGist -- Turn on https
                           , HTTP.method = "POST"
                           , HTTP.requestHeaders = [customHeader, ("User-Agent", "HsCMS")]
                           , HTTP.requestBody = HTTP.RequestBodyBS (BS.pack (strToWord8s body))
                           }
        --let req = (flip HTTP.urlEncodedBody) req' $ [ ("", (BS.pack (strToWord8s body))) ]
        res <- HTTP.httpLbs req manager
        return $ HTTP.responseBody res

-- Create a gist
createGist :: (MonadIO m, MonadBaseControl IO m) => Maybe Text -> String -> m BL.ByteString
createGist githubKey body = do
   case githubKey of
       Nothing -> return $ "URL Syntax Error"
       Just gkey -> if testingGist then submitPostRequest "http://www.posttestserver.com/post.php?dir=Testing" (unpack gkey) body
           else submitPostRequest "https://api.github.com/gists" (unpack gkey) body

-- Update a gist from a given id
updateGist :: (MonadIO m, MonadBaseControl IO m) => Maybe Text -> String -> String -> m BL.ByteString
updateGist githubKey gistId body = do
   case githubKey of
       Nothing -> return $ "URL Syntax Error"
       Just gkey -> submitPostRequest ("https://api.github.com/gists/" ++ gistId) (unpack gkey) body



-- .........


-- Handling the new posted blog post
postAdminNewArticleR :: Handler Html
postAdminNewArticleR = do
    title <- runInputPost $ ireq textField "form-title-field"
    mdContent <- runInputPost $ ireq htmlField "form-mdcontent-field"
    htmlContent <- runInputPost $ ireq htmlField "form-htmlcontent-field"
    wordCount <- runInputPost $ ireq intField "form-wordcount-field"
    publish <- runInputPost $ iopt boolField "form-publish"
    added <- liftIO getCurrentTime
    userId <- requireAuthId
    case publish of
        Nothing -> do
            articleId <- runDB $ insert $ Article title mdContent htmlContent wordCount added userId Nothing False False
            setMessage $ "Saved Post: " <> (toHtml title)
            redirect (AdminUpdateArticleR articleId)
        Just _ -> do
            extra <- getExtra
            res <- createGist (extraGithubKey extra) $ "{\"description\": \"" ++ (unpack title) ++ "\", \"public\": \"true\", \"files\": {\"" ++ (unpack title) ++ ".md\": {\"content\": \"" ++ (TL.unpack (renderHtml mdContent)) ++ "\"}}"
            liftIO $ BL.putStrLn res -- DEBUGGING!
            _ <- runDB $ insert $ Article title mdContent htmlContent wordCount added userId Nothing True False
            setMessage $ "Created Post: " <> (toHtml title)
            redirect AdminShowArticlesR