From 9ed384ed32552850689e3f51f7ec8a3ff2b24738 Mon Sep 17 00:00:00 2001
From: Adrian Sieber <mail@adriansieber.com>
Date: Mon, 29 Jan 2024 18:56:51 +0000
Subject: [PATCH] Make authentication mandatory for uploading files to
 Airsequel

---
 app/FileUploader.hs | 27 +++++++++++++++++++++++----
 app/Main.hs         | 10 ++++++++--
 2 files changed, 31 insertions(+), 6 deletions(-)

diff --git a/app/FileUploader.hs b/app/FileUploader.hs
index 90ed00d..61588dc 100644
--- a/app/FileUploader.hs
+++ b/app/FileUploader.hs
@@ -40,6 +40,7 @@ import Network.HTTP.Client (
   httpLbs,
   newManager,
   parseRequest,
+  requestHeaders,
  )
 import Network.HTTP.Client.MultipartFormData (formDataBody, partFileSource)
 import Network.HTTP.Client.TLS (tlsManagerSettings)
@@ -92,6 +93,7 @@ getFilesSorted path = do
     & filterM (doesFileExist . (path </>))
     <&> ( P.filter (/= ".DS_Store")
             >>> P.sort
+            >>> P.map (path </>)
         )
 
 
@@ -107,8 +109,8 @@ createSQLQuery tableName fileData =
     <> "RETURNING rowid"
 
 
-uploadFiles :: Text -> Text -> Text -> [FilePath] -> IO ()
-uploadFiles domain dbId tableName paths = do
+uploadFiles :: Text -> Text -> Text -> Text -> [FilePath] -> IO ()
+uploadFiles domain airseqWriteToken dbId tableName paths = do
   manager <- newManager tlsManagerSettings
 
   fileLists <- P.forM paths $ \filePath -> do
@@ -136,7 +138,10 @@ uploadFiles domain dbId tableName paths = do
         initialRequest
           { method = "POST"
           , requestBody = RequestBodyLBS $ encode $ object ["query" .= query]
-          , requestHeaders = [("Content-Type", "application/json")]
+          , requestHeaders =
+              [ ("Content-Type", "application/json")
+              , ("Authorization", "Bearer " <> airseqWriteToken & P.encodeUtf8)
+              ]
           }
 
     sqlResponse <- httpLbs sqlRequest manager
@@ -199,7 +204,21 @@ uploadFiles domain dbId tableName paths = do
 
         fileRes <-
           flip httpLbs manager
-            =<< (fileRequest <&> (\req -> req{method = methodPut}))
+            =<< ( fileRequest
+                    <&> ( \req ->
+                            req
+                              { method = methodPut
+                              , requestHeaders =
+                                  requestHeaders req
+                                    <> [
+                                         ( "Authorization"
+                                         , "Bearer "
+                                            <> airseqWriteToken & P.encodeUtf8
+                                         )
+                                       ]
+                              }
+                        )
+                )
 
         if (fileRes.responseStatus.statusMessage /= "OK")
           || ("error" `BS.isInfixOf` (fileRes.responseBody & BSL.toStrict))
diff --git a/app/Main.hs b/app/Main.hs
index dd5a4f0..8b9dc6a 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -81,7 +81,7 @@ import Text.RawString.QQ (r)
 import Airsequel (saveReposInAirsequel)
 import FileUploader (uploadFiles)
 import Types (GqlRepoRes (..), Repo (..), SaveStrategy (..))
-import Utils (loadGitHubToken)
+import Utils (loadAirsWriteToken, loadGitHubToken)
 
 
 data CliCmd
@@ -396,7 +396,13 @@ run :: CliCmd -> IO ()
 run cliCmd = do
   case cliCmd of
     FileUpload{domain, dbId, tableName, paths} -> do
-      uploadFiles (T.pack domain) (T.pack dbId) (T.pack tableName) paths
+      airsWriteToken <- loadAirsWriteToken
+      uploadFiles
+        (T.pack domain)
+        airsWriteToken
+        (T.pack dbId)
+        (T.pack tableName)
+        paths
     --
     GithubUpload repoSlug -> do
       ghTokenMb <- loadGitHubToken