Merge branch 'master' of https://github.com/FileFighter/FileHandler

Author: qvalentin

Filehandler.cabal

@@ -7,13 +7,13 @@ cabal-version: 1.12
 -- hash: 810c23ddfee0d410c3632560ab726ca5db1e957ed8095989f8e2e7e554eb65f4
 
 name:           Filehandler
-version:        0.1.0.0
+version:        0.0.2
 description:    Please see the README on GitHub at <https://github.com/githubuser/Filehandler#readme>
 homepage:       https://github.com/githubuser/Filehandler#readme
 bug-reports:    https://github.com/githubuser/Filehandler/issues
-author:         Author name here
+author:         FileFighter
 maintainer:     [email protected]
-copyright:      2021 Author name here
+copyright:      2021 FileFighter
 license:        BSD3
 license-file:   LICENSE
 build-type:     Simple

app/Main.hs

@@ -16,6 +16,7 @@ import qualified Data.ByteString.Char8 as S8
 import qualified Data.ByteString.Lazy as L
 import Data.CaseInsensitive
 import Data.Functor.Identity
+import Data.Maybe (fromMaybe)
 import qualified Data.Text as DataText
 import GHC.Generics
 import GHC.Int
@@ -32,7 +33,7 @@ import System.Environment
 import System.FilePath
 import System.IO
 import System.IO.Temp
-import Data.Maybe ( fromMaybe )
+import GHC.IO.Encoding (setLocaleEncoding)
 
 -- | Entrypoint to our application
 main :: IO ()
@@ -44,6 +45,7 @@ main = do
   --  If we have the argument "sanity", immediately exit
   --  If we have no arguments, run the server
   --  Otherwise, error out
+  setLocaleEncoding utf8
   args <- getArgs
   case args of
     ["sanity"] -> putStrLn "Sanity check passed, ready to roll!"
@@ -159,74 +161,83 @@ postApi allHeaders file restUrl fileId = runReq (defaultHttpConfig {httpConfigCh
 download :: Application
 download req send = do
   let headers = requestHeaders req
-  restUrl <- getRestUrl
-  logStdOut "download"
-  (responseBody, responseStatusCode, responseStatusMessage) <- getApi headers restUrl
-  case responseStatusCode of
-    200 -> do
-      let d = (eitherDecode $ L.fromStrict responseBody) :: (Either String [RestResponseFile])
-      case d of
-        Left err ->
-          send $
-            responseLBS
-              HttpTypes.status501
-              [("Content-Type", "application/json; charset=utf-8")]
-              (L.fromStrict $ S8.pack err)
-        Right files ->
-          case files of
-            [fileObject] -> do
-              let fileID = fileSystemId fileObject
-                  path = getPathFromFileId $ show fileID
-                  realName = name fileObject
-                  fileMimeType = fromMaybe "application/octet-stream" (mimeType fileObject)
-              send $
-                responseFile
-                  HttpTypes.status200
-                  [ ("Content-Disposition", S8.pack ("attachment; filename=\"" ++ realName ++ "\"")),
-                    ("Content-Type", S8.pack fileMimeType)
-                  ]
-                  path
-                  Nothing
-            xs ->
-              withSystemTempFile "FileFighterFileHandler.zip" $
-                \tmpFileName handle ->
-                  do
-                    let nameOfTheFolder = "NameOfTheFolderToDownload.zip"
-                    let ss =
-                          mapM
-                            ( \file -> do
-                                inZipPath <- mkEntrySelector $ fromMaybe (name file) (path file)
-                                loadEntry Store inZipPath (getPathFromFileId (show $ fileSystemId file))
-                            )
-                            xs
-                    createArchive tmpFileName ss
-                    send $
-                      responseFile
-                        HttpTypes.status200
-                        [ ("Content-Disposition", S8.pack ("attachment; filename=\"" ++ nameOfTheFolder ++ "\"")),
-                          ("Content-Type", "application/zip")
-                        ]
-                        tmpFileName
-                        Nothing
-    _ ->
+      queryParam = getDownloadQuery $ queryString req
+  case queryParam of
+    Nothing ->
       send $
         responseLBS
-          (HttpTypes.mkStatus responseStatusCode responseStatusMessage)
+          HttpTypes.status501
           [("Content-Type", "application/json; charset=utf-8")]
-          (L.fromStrict responseBody)
+          "No ids parameter supplied."
+    Just param -> do
+      restUrl <- getRestUrl
+      logStdOut "download"
+      (responseBody, responseStatusCode, responseStatusMessage, fileNameHeader) <- getApi headers param restUrl
+      case responseStatusCode of
+        200 -> do
+          let d = (eitherDecode $ L.fromStrict responseBody) :: (Either String [RestResponseFile])
+          case d of
+            Left err ->
+              send $
+                responseLBS
+                  HttpTypes.status501
+                  [("Content-Type", "application/json; charset=utf-8")]
+                  (L.fromStrict $ S8.pack err)
+            Right files ->
+              case files of
+                [fileObject] -> do
+                  let fileID = fileSystemId fileObject
+                      path = getPathFromFileId $ show fileID
+                      realName = name fileObject
+                      fileMimeType = fromMaybe "application/octet-stream" (mimeType fileObject)
+                  send $
+                    responseFile
+                      HttpTypes.status200
+                      [ ("Content-Disposition", S8.pack ("attachment; filename=\"" ++ realName ++ "\"")),
+                        ("Content-Type", S8.pack fileMimeType)
+                      ]
+                      path
+                      Nothing
+                xs ->
+                  withSystemTempFile "FileFighterFileHandler.zip" $
+                    \tmpFileName handle ->
+                      do
+                        let nameOfTheFolder = fromMaybe "Files" fileNameHeader
+                        let ss =
+                              mapM
+                                ( \file -> do
+                                    inZipPath <- mkEntrySelector $ fromMaybe (name file) (path file)
+                                    loadEntry Store inZipPath (getPathFromFileId (show $ fileSystemId file))
+                                )
+                                xs
+                        createArchive tmpFileName ss
+                        send $
+                          responseFile
+                            HttpTypes.status200
+                            [ ("Content-Disposition", S8.pack ("attachment; filename=\"" ++ S8.unpack nameOfTheFolder ++ ".zip" ++ "\"")),
+                              ("Content-Type", "application/zip")
+                            ]
+                            tmpFileName
+                            Nothing
+        _ ->
+          send $
+            responseLBS
+              (HttpTypes.mkStatus responseStatusCode responseStatusMessage)
+              [("Content-Type", "application/json; charset=utf-8")]
+              (L.fromStrict responseBody)
 
-getApi :: [HttpTypes.Header] -> String -> IO (S8.ByteString, Int, S8.ByteString)
-getApi allHeaders restUrl = runReq (defaultHttpConfig {httpConfigCheckResponse = httpConfigDontCheckResponse}) $ do
+getApi :: [HttpTypes.Header] -> String -> String -> IO (S8.ByteString, Int, S8.ByteString, Maybe S8.ByteString)
+getApi allHeaders param restUrl = runReq (defaultHttpConfig {httpConfigCheckResponse = httpConfigDontCheckResponse}) $ do
   r <-
     req
       GET -- method
-      (http (DataText.pack restUrl) /: "v1"  /: "filesystem" /: "download") -- safe by construction URL
+      (http (DataText.pack restUrl) /: "api" /: "v1" /: "filesystem" /: "download") -- safe by construction URL
       -- (http (DataText.pack restUrl) /:"v1" /: "filesystem" /: DataText.pack  (S8.unpack (getOneHeader allHeaders "X-FF-IDS" )) /: "info")
       NoReqBody -- use built-in options or add your own
       bsResponse -- specify how to interpret response
-      (header "X-FF-IDS" (getOneHeader allHeaders "X-FF-IDS") <> header "Authorization" (getOneHeader allHeaders "Authorization")  <> port 8080) --PORT !!
+      (header "X-FF-IDS" (getOneHeader allHeaders "X-FF-IDS") <> header "Cookie" (getOneHeader allHeaders "Cookie") <> port 8080 <> (=:) "ids" param) --PORT !!
       -- mempty -- query params, headers, explicit port number, etc.
-  return (responseBody r, responseStatusCode r, responseStatusMessage r)
+  return (responseBody r, responseStatusCode r, responseStatusMessage r, responseHeader r "X-FF-NAME")
 
 delete :: Application
 delete req send = do
@@ -263,7 +274,7 @@ deleteApi allHeaders restUrl fileId = runReq (defaultHttpConfig {httpConfigCheck
   r <-
     req
       DELETE
-      (http (DataText.pack restUrl) /: "api" /: "v1" /: "filesystem" /: DataText.pack fileId /: "delete") 
+      (http (DataText.pack restUrl) /: "api" /: "v1" /: "filesystem" /: DataText.pack fileId /: "delete")
       NoReqBody
       bsResponse
       (header "Authorization" (getOneHeader allHeaders "Authorization") <> port 8080) -- parentID not in Headers
@@ -279,7 +290,7 @@ health req send = do
 
   let response =
         object
-          [ "version" .= ("1.0.0" :: String),
+          [ "version" .= ("0.2.0" :: String),
             "deploymentType" .= deploymentType,
             "actualFilesSize" .= actualFilesSize,
             "fileCount" .= length files
@@ -296,6 +307,10 @@ getOneHeader headers headerName =
     [header] -> snd header
     _ -> ""
 
+getDownloadQuery :: HttpTypes.Query -> Maybe String
+getDownloadQuery [(param, Just value)] = if param == "ids" then Just (S8.unpack value) else Nothing
+getDownloadQuery _ = Nothing
+
 -- needed because buffering is causing problems with docker
 logStdOut :: String -> IO ()
 logStdOut text = do
@@ -355,7 +370,7 @@ instance ToJSON User
 
 data RestResponseFile = RestResponseFile
   { fileSystemId :: !Int,
-    name ::  String,
+    name :: String,
     path :: Maybe String,
     size :: Int,
     owner :: User,