From 06fa97bfcf255fd033d3b5bd77d77d68ec8beef6 Mon Sep 17 00:00:00 2001
From: Eugen Wissner <belka@caraus.de>
Date: Tue, 18 Feb 2025 11:57:18 +0100
Subject: tea-cleaner: Read configuration file

---
 tea-cleaner/TeaCleaner/Client.hs | 45 +++++++++++++++++++++-------------------
 1 file changed, 24 insertions(+), 21 deletions(-)

(limited to 'tea-cleaner/TeaCleaner/Client.hs')

diff --git a/tea-cleaner/TeaCleaner/Client.hs b/tea-cleaner/TeaCleaner/Client.hs
index af84514..5afd6a5 100644
--- a/tea-cleaner/TeaCleaner/Client.hs
+++ b/tea-cleaner/TeaCleaner/Client.hs
@@ -10,13 +10,17 @@ import Data.List.NonEmpty (NonEmpty(..))
 import Data.Text (StrictText)
 import qualified Data.Text.Encoding as Text.Encoding
 import Data.Vector (Vector)
-import Text.URI (URI(..))
 import qualified Text.URI as URI
 import qualified Text.URI.QQ as URI
 import Network.HTTP.Req
     ( DELETE(..)
     , GET(..)
     , NoReqBody(..)
+    , HttpMethod(..)
+    , HttpBody
+    , HttpResponse(..)
+    , HttpBodyAllowed
+    , ProvidesBody
     , defaultHttpConfig
     , ignoreResponse
     , jsonResponse
@@ -31,6 +35,9 @@ import TeaCleaner.Options (jsonOptions)
 import Data.Int (Int64)
 import qualified Data.Aeson.TH as Aeson
 import Data.Time (ZonedTime(..))
+import TeaCleaner.Configuration (Settings(..))
+import Data.Data (Proxy)
+import Text.URI (URI)
 
 data User = User
     { id :: Int64
@@ -75,8 +82,8 @@ data Activity = Activity
 
 $(Aeson.deriveJSON jsonOptions ''Activity)
 
-purgeUser :: URI -> StrictText -> User -> IO ()
-purgeUser server token user =
+purgeUser :: Settings -> User -> IO ()
+purgeUser Settings{..} user =
     let pathConstructor lastPiece = [URI.pathPiece|api|] :|
             [ [URI.pathPiece|v1|]
             , [URI.pathPiece|admin|]
@@ -88,15 +95,10 @@ purgeUser server token user =
                 <$> URI.mkPathPiece (getField @"username" user)
             , URI.uriQuery = [URI.QueryParam [URI.queryKey|purge|] [URI.queryValue|true|]]
             }
-     in case useHttpsURI uri of
-        Just (httpsURI, httpsOptions) -> fmap responseBody
-            $ runReq defaultHttpConfig
-            $ req DELETE httpsURI NoReqBody ignoreResponse
-            $ httpsOptions <> oAuth2Bearer (Text.Encoding.encodeUtf8 token)
-        Nothing -> error "Invalid https URI"
+     in doRequest uri token DELETE NoReqBody ignoreResponse
 
-getActivities :: URI -> StrictText -> User -> IO (Vector Activity)
-getActivities server token user =
+getActivities :: Settings -> User -> IO (Vector Activity)
+getActivities Settings{..} user =
     let pathConstructor lastPiece = [URI.pathPiece|api|] :|
             [ [URI.pathPiece|v1|]
             , [URI.pathPiece|users|]
@@ -109,15 +111,10 @@ getActivities server token user =
                 <$> URI.mkPathPiece (getField @"username" user)
             , URI.uriQuery = [URI.QueryParam [URI.queryKey|purge|] [URI.queryValue|true|]]
             }
-     in case useHttpsURI uri of
-        Just (httpsURI, httpsOptions) -> fmap responseBody
-            $ runReq defaultHttpConfig
-            $ req GET httpsURI NoReqBody jsonResponse
-            $ httpsOptions <> oAuth2Bearer (Text.Encoding.encodeUtf8 token)
-        Nothing -> error "Invalid https URI"
+     in doRequest uri token GET NoReqBody jsonResponse
 
-getUsers :: URI -> StrictText -> IO (Vector User)
-getUsers server token =
+getUsers :: Settings -> IO (Vector User)
+getUsers Settings{..} =
     let pathPieces = [URI.pathPiece|api|] :|
             [ [URI.pathPiece|v1|]
             , [URI.pathPiece|admin|]
@@ -126,9 +123,15 @@ getUsers server token =
         uri = server
             { URI.uriPath = Just (False, pathPieces)
             }
-     in case useHttpsURI uri of
+     in doRequest uri token GET NoReqBody jsonResponse
+
+doRequest
+    :: (HttpMethod method, HttpBody body, HttpResponse response, HttpBodyAllowed (AllowsBody method) (ProvidesBody body))
+    => URI -> StrictText -> method -> body -> Proxy response -> IO (HttpResponseBody response)
+doRequest uri token method body response =
+    case useHttpsURI uri of
         Just (httpsURI, httpsOptions) -> fmap responseBody
             $ runReq defaultHttpConfig
-            $ req GET httpsURI NoReqBody jsonResponse
+            $ req method httpsURI body response
             $ httpsOptions <> oAuth2Bearer (Text.Encoding.encodeUtf8 token)
         Nothing -> error "Invalid https URI"
-- 
cgit v1.2.3