Move get/post definitions out of DataClient into Common (to be used by chandlr-server)

chan-delorean.cabal

@@ -76,6 +76,7 @@ executable chan-delorean
                       JSONCommonTypes
                       Common.PostsType
                       Common.AttachmentType
+                      Common.Network.HttpClient
                       Hash
                       Data.WordUtil
 

src/Common

@@ -1 +1 @@
-Subproject commit affc7f7d442a0600f75e1d0dec69ac9eb40e12ca
+Subproject commit 1264424bd541649a2f163542a93203235e996ac3

src/DataClient.hs

@@ -20,21 +20,10 @@ module DataClient
 import Control.Monad (forM)
 import Data.Int (Int64)
 import Data.Either (lefts, rights)
-import Network.HTTP.Simple hiding (httpLbs)
-import Network.HTTP.Client
-    ( newManager
-    , managerSetMaxHeaderLength
-    , httpLbs
-    , responseTimeoutNone
-    )
 import qualified Data.ByteString.Lazy.Char8 as BL
-import Network.HTTP.Client.Conduit (defaultManagerSettings)
 import qualified Data.ByteString.Lazy as LBS
 import qualified Data.ByteString.Lazy.Char8 as LC8
-import Network.HTTP.Types.Status (statusCode)
-import Control.Exception.Safe (tryAny, SomeException)
 import Data.List (intercalate)
-import qualified Data.ByteString.Char8 as C8
 import Data.Aeson
   ( eitherDecode
   , FromJSON
@@ -51,11 +40,7 @@ import qualified BoardsType as Boards
 import qualified ThreadType as Threads
 import qualified Common.AttachmentType as Attachments
 import qualified Common.PostsType  as Posts
-
-data HttpError
-    = HttpException SomeException
-    | StatusCodeError Int LBS.ByteString
-    deriving (Show)
+import Common.Network.HttpClient
 
 data PostId = PostId
     { post_id :: Int64
@@ -63,69 +48,6 @@ data PostId = PostId
     , thread_id :: Int64
     } deriving (Show, Generic, FromJSON)
 
-{-
-data AttachmentId = AttachmentId
-    { attachment_id :: Int64
-    , post_id_ :: Int64
-    , sha256_hash :: Text
-    } deriving (Show, Generic, FromJSON)
--}
-
-get :: T.JSONSettings -> String -> IO (Either HttpError LBS.ByteString)
-get settings path = do
-    let requestUrl = T.postgrest_url settings ++ path
-    initReq <- parseRequest requestUrl
-    let req = setRequestHeader "Authorization" [C8.pack $ "Bearer " ++ T.jwt settings] initReq
-    putStrLn $ "calling " ++ requestUrl
-
-    let man_settings = managerSetMaxHeaderLength (16384 * 4) defaultManagerSettings
-    manager <- newManager man_settings
-    handleHttp (httpLbs req manager)
-
-
-post
-  :: T.JSONSettings
-  -> String
-  -> LBS.ByteString
-  -> Bool
-  -> IO (Either HttpError LBS.ByteString)
-post settings path payload return_repr = do
-    let requestUrl = T.postgrest_url settings ++ path
-    req <- parseRequest requestUrl
-    let initReq = setRequestResponseTimeout responseTimeoutNone req
-    let request = setRequestMethod "POST"
-            . setRequestHeader "Authorization" [ jwt_header ]
-            . setRequestHeader "Content-Type" [ "application/json" ]
-            . setRequestBodyLBS payload
-            . prefer
-            $ initReq
-
-    putStrLn $ "posting to " ++ requestUrl
-    -- putStrLn $ "Payload: " ++ (LC8.unpack payload)
-    handleHttp (httpLBS request)
-
-    where
-      jwt_header = C8.pack $ "Bearer " ++ T.jwt settings
-      prefer =
-        if return_repr
-        then setRequestHeader "Prefer" [ "return=representation" ]
-        else id
-
-
-handleHttp :: IO (Response LBS.ByteString) -> IO (Either HttpError LBS.ByteString)
-handleHttp action = do
-    result <- tryAny action
-    case result of
-        Right response -> 
-            let responseBody = getResponseBody response
-            in if 200 <= (statusCode $ getResponseStatus response) && (statusCode $ getResponseStatus response) < 300
-               then return $ Right responseBody
-               else return $ Left (StatusCodeError (statusCode $ getResponseStatus response) responseBody)
-        Left e -> do
-            putStrLn "Some nasty http exception must have occurred"
-            return $ Left $ HttpException e
-
-
 getSiteBoards :: T.JSONSettings -> Int -> IO (Either HttpError [ Boards.Board ])
 getSiteBoards settings site_id_ = get settings path >>= return . eitherDecodeResponse
   where