From 081f334fade35ed5893377ee89d8e3121f451202 Mon Sep 17 00:00:00 2001
From: towards-a-new-leftypol <paul_cockshott@protonmail.com>
Date: Mon, 18 Mar 2024 08:34:35 -0400
Subject: [PATCH] Move get/post definitions out of DataClient into Common (to
 be used by chandlr-server)

---
 chan-delorean.cabal |  1 +
 src/Common          |  2 +-
 src/DataClient.hs   | 80 +--------------------------------------------
 3 files changed, 3 insertions(+), 80 deletions(-)

diff --git a/chan-delorean.cabal b/chan-delorean.cabal
index 6af8b36..1b0a10f 100644
--- a/chan-delorean.cabal
+++ b/chan-delorean.cabal
@@ -76,6 +76,7 @@ executable chan-delorean
                       JSONCommonTypes
                       Common.PostsType
                       Common.AttachmentType
+                      Common.Network.HttpClient
                       Hash
                       Data.WordUtil
 
diff --git a/src/Common b/src/Common
index affc7f7..1264424 160000
--- a/src/Common
+++ b/src/Common
@@ -1 +1 @@
-Subproject commit affc7f7d442a0600f75e1d0dec69ac9eb40e12ca
+Subproject commit 1264424bd541649a2f163542a93203235e996ac3
diff --git a/src/DataClient.hs b/src/DataClient.hs
index 330c1e5..969dbf4 100644
--- a/src/DataClient.hs
+++ b/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