From d28c16dec0be38f161b5e7c054aa349121e188d9 Mon Sep 17 00:00:00 2001 From: qvalentin Date: Sat, 29 Jan 2022 12:16:41 +0100 Subject: [PATCH 01/35] Migrate to Yesod Framework --- .gitignore | 41 +++- ChangeLog.md | 3 - Filehandler.cabal | 82 ------- README.md | 48 ++-- Setup.hs | 2 - app/Main.hs | 475 +----------------------------------- package.yaml | 38 +++ routes.yesodroutes | 6 + src/Application.hs | 18 ++ src/Foundation.hs | 13 + src/Handler/Delete.hs | 71 ++++++ src/Handler/Download.hs | 142 +++++++++++ src/Handler/Health.hs | 35 +++ src/Handler/Home.hs | 12 + src/Handler/Preview.hs | 93 +++++++ src/Handler/Upload.hs | 109 +++++++++ src/Lib.hs | 15 -- src/Logger.hs | 9 + src/Models/Inode.hs | 35 +++ src/Models/RestApiStatus.hs | 17 ++ src/Models/User.hs | 16 ++ src/Utils/FileUtils.hs | 12 + src/Utils/FileUtils.sh | 1 + src/Utils/RequestUtils.hs | 20 ++ stack.yaml | 22 +- stack.yaml.lock | 8 +- test/Spec.hs | 18 -- 27 files changed, 713 insertions(+), 648 deletions(-) delete mode 100644 ChangeLog.md delete mode 100644 Filehandler.cabal delete mode 100644 Setup.hs create mode 100644 package.yaml create mode 100644 routes.yesodroutes create mode 100644 src/Application.hs create mode 100644 src/Foundation.hs create mode 100644 src/Handler/Delete.hs create mode 100644 src/Handler/Download.hs create mode 100644 src/Handler/Health.hs create mode 100644 src/Handler/Home.hs create mode 100644 src/Handler/Preview.hs create mode 100644 src/Handler/Upload.hs delete mode 100644 src/Lib.hs create mode 100644 src/Logger.hs create mode 100644 src/Models/Inode.hs create mode 100644 src/Models/RestApiStatus.hs create mode 100644 src/Models/User.hs create mode 100644 src/Utils/FileUtils.hs create mode 100644 src/Utils/FileUtils.sh create mode 100644 src/Utils/RequestUtils.hs delete mode 100644 test/Spec.hs diff --git a/.gitignore b/.gitignore index 0b4de9a..6d03cad 100644 --- a/.gitignore +++ b/.gitignore @@ -1,20 +1,35 @@ -dist -dist-* -cabal-dev -*.o -*.hi +*.aux *.chi *.chs.h -*.dyn_o *.dyn_hi +*.dyn_o +*.eventlog +*.hi +*.hp +*.keter +*.o +*.prof +*.sqlite3 +*.sqlite3-shm +*.sqlite3-wal +*.swp +*~ +*~dist* +.DS_Store +.cabal-sandbox .hpc .hsenv -.cabal-sandbox/ -cabal.sandbox.config -*.prof -*.aux -*.hp -*.eventlog +.hsenv* +.stack-work-devel/ .stack-work/ +FileHandlerYesod.cabal +\#* +cabal-dev cabal.project.local -*~ \ No newline at end of file +cabal.sandbox.config +config/client_session_key.aes +dist +dist-* +static/combined/ +static/tmp/ +yesod-devel/ diff --git a/ChangeLog.md b/ChangeLog.md deleted file mode 100644 index 3e2c396..0000000 --- a/ChangeLog.md +++ /dev/null @@ -1,3 +0,0 @@ -# Changelog for Filehandler - -## Unreleased changes diff --git a/Filehandler.cabal b/Filehandler.cabal deleted file mode 100644 index 633b21d..0000000 --- a/Filehandler.cabal +++ /dev/null @@ -1,82 +0,0 @@ -cabal-version: 1.12 - --- This file has been generated from package.yaml by hpack version 0.33.0. --- --- see: https://github.com/sol/hpack --- --- hash: 810c23ddfee0d410c3632560ab726ca5db1e957ed8095989f8e2e7e554eb65f4 - -name: Filehandler -version: 0.0.2 -description: Please see the README on GitHub at -homepage: https://github.com/githubuser/Filehandler#readme -bug-reports: https://github.com/githubuser/Filehandler/issues -author: FileFighter -maintainer: example@example.com -copyright: 2021 FileFighter -license: BSD3 -license-file: LICENSE -build-type: Simple -extra-source-files: - README.md - ChangeLog.md - -source-repository head - type: git - location: https://github.com/FileFighter/Filehandler - -library - exposed-modules: - Lib - other-modules: - Paths_Filehandler - hs-source-dirs: - src - build-depends: - base >=4.7 && <5 - default-language: Haskell2010 - -executable Filehandler-exe - main-is: Main.hs - other-modules: - Paths_Filehandler - hs-source-dirs: - app - ghc-options: -threaded -rtsopts -with-rtsopts=-N - build-depends: - Filehandler - , base >=4.7 && <5 - , req - , wai - , wai-app-static - , wai-extra - , wai-cors - , warp - , network - , text - , aeson - , filepath - , http-types - , bytestring - , directory - , case-insensitive - , mtl - , resourcet - , zip - , temporary - default-language: Haskell2010 - -test-suite Filehandler-test - type: exitcode-stdio-1.0 - main-is: Spec.hs - other-modules: - Paths_Filehandler - hs-source-dirs: - test - ghc-options: -threaded -rtsopts -with-rtsopts=-N - build-depends: - Filehandler - , base >=4.7 && <5 - , hspec - , QuickCheck - default-language: Haskell2010 diff --git a/README.md b/README.md index 318e774..bce35be 100644 --- a/README.md +++ b/README.md @@ -1,31 +1,37 @@ -# FileHandlerService -Haskell FileHandler Server. +# FileHanderService +Haskell FileHandler Server for the [FileFighter](https://github.com/FileFighter) NAS Project. -_Work In Progress_ +Build using the Yesod Framework (see below). -Base of this code base is this [repo](https://github.com/snoyberg/file-server-demo) +## Haskell Setup -## Features -- [ ] browse does not exist anymore. -- [ ] upload path is POST /upload?id=id,id1,id2&token=token -- [ ] request to upload triggers request to backend -- [ ] upload does support multiple files -- [ ] download path is GET /download?id=id,id1,id2&token=token -- [ ] request to download triggers request to backend -- [ ] download supports multiple files (zipped as one) -- [ ] service is either mapped with a usefull prefix /userdata/ or a fake subdomain files.....de/upload... -**(Roadmap feature)** -- [ ] there is another path /preview/id?token=token +1. If you haven't already, [install Stack](https://haskell-lang.org/get-started) + * On POSIX systems, this is usually `curl -sSL https://get.haskellstack.org/ | sh` +2. Install GHC: `stack setup` +3. Build libraries: `stack build` -Text below is from the original code base. +## Development ---- +Start a development server with: -# Getting started +``` +stack build --exec test-minimal +``` -`stack build --file-watch --watch-all --fast` +## Documentation -`filewatcher --restart '**/*.hs' 'stack build --fast && stack exec Filehandler-exe'` +* Read the [Yesod Book](https://www.yesodweb.com/book) online for free +* Check [Stackage](http://stackage.org/) for documentation on the packages in your LTS Haskell version, or [search it using Hoogle](https://www.stackage.org/lts/hoogle?q=). Tip: Your LTS version is in your `stack.yaml` file. +* For local documentation, use: + * `stack haddock --open` to generate Haddock documentation for your dependencies, and open that documentation in a browser + * `stack hoogle ` to generate a Hoogle database and search for your query +* The [Yesod cookbook](https://github.com/yesodweb/yesod-cookbook) has sample code for various needs -`stack exec Filehandler-exe` +## Getting Help + +* Ask questions on [Stack Overflow, using the Yesod or Haskell tags](https://stackoverflow.com/questions/tagged/yesod+haskell) +* Ask the [Yesod Google Group](https://groups.google.com/forum/#!forum/yesodweb) +* There are several chatrooms you can ask for help: + * For IRC, try Freenode#yesod and Freenode#haskell + * [Functional Programming Slack](https://fpchat-invite.herokuapp.com/), in the #haskell, #haskell-beginners, or #yesod channels. diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 index 9a994af..0000000 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/app/Main.hs b/app/Main.hs index e8eb57e..5ed9ac4 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,473 +1,6 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} +import Application () -- for YesodDispatch instance +import Foundation +import Yesod.Core -module Main where - --- Import the various modules that we'll use in our code. - -import Codec.Archive.Zip -import Control.Monad.IO.Class -import Control.Monad.State -import Control.Monad.Trans.Resource -import Data.Aeson -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.IO.Encoding (setLocaleEncoding) -import GHC.Int -import Lib -import Network.HTTP.Req -import qualified Network.HTTP.Types as HttpTypes -import Network.Wai -import Network.Wai.Application.Static -import Network.Wai.Handler.Warp -import Network.Wai.Middleware.Cors -import Network.Wai.Parse -import System.Directory -import System.Environment -import System.FilePath -import System.IO -import System.IO.Temp - --- | Entrypoint to our application main :: IO () -main = do - -- For ease of setup, we want to have a "sanity" command line - -- argument. - -- - -- If we have the argument "sanity", immediately exit - setLocaleEncoding utf8 - args <- getArgs - case args of - ["sanity"] -> putStrLn "Sanity check passed, ready to roll!" - [restUrl, "dev"] -> do - logStdOut "Launching DataHandler with dev profile" - -- Run our application (defined below) on port 5000 with cors enabled - run 5000 $ cors (const devCorsPolicy) app - [restUrl, "stage"] -> do - logStdOut "Launching DataHandler with stage profile" - -- Run our application (defined below) on port 5000 with cors enabled - run 5000 $ cors (const devCorsPolicy) app - [restUrl, "prod"] -> do - logStdOut "Launching DataHandler with prod profile" - -- Run our application (defined below) on port 5000 - run 5000 app - _ -> error $ "Unknown arguments: " ++ show args - --- | Our main application -app :: Application -app req send = - -- Route the request based on the path requested - case pathInfo req of - -- "/upload": handle a file upload - ["data", "upload", id] -> upload req send - ["data", "download"] -> download req send - ["data", "delete", id] -> delete req send - ["data", "preview", id] -> preview req send - ["data", "preview", id, _] -> preview req send - ["data", "health"] -> health req send - -- anything else: 404 - missingEndpoint -> - send $ - responseLBS - HttpTypes.status404 - [("Content-Type", "application/json; charset=utf-8")] - (encode $ RestApiStatus ("FileHandler: This endpoint does not exist." ++ show missingEndpoint) "Not Found") - -upload :: Application -upload req send = runResourceT $ - withInternalState $ - \internalState -> - do - (_params, files) <- parseRequestBody (tempFileBackEnd internalState) req - let headers = requestHeaders req - -- debug (_params) - -- Look for the file parameter called "file" - case lookup "file" files of - -- Not found, so return a 400 response - Nothing -> - send $ - responseLBS - HttpTypes.status400 - [("Content-Type", "application/json; charset=utf-8")] - (encode $ RestApiStatus "No file parameter found" "Bad Request") - -- Got it! - Just file -> do - let content = fileContent file - restUrl <- getRestUrl - (responseBody, responseStatusCode, responseStatusMessage) <- postApi headers file restUrl (DataText.unpack $ pathInfo req !! 2) - case responseStatusCode of - 201 -> do - let d = (eitherDecode $ L.fromStrict responseBody) :: (Either String [RestResponseFile]) - case d of - Left err -> - send $ - responseLBS - HttpTypes.status500 - [("Content-Type", "application/json; charset=utf-8")] - (encode $ RestApiStatus err "Internal Server Error") - Right filesAndFolders -> - case filter filterFiles filesAndFolders of - [] -> - send $ - responseLBS - HttpTypes.status500 - [("Content-Type", "application/json; charset=utf-8")] - (encode $ RestApiStatus "No file found in rest response." "Internal Server Error") - [file] -> do - let id = show $ fileSystemId file - createDirectoryIfMissing True [head id] - copyFile content (getPathFromFileId id) - logStdOut ("Uploaded " ++ (head id : ("/" ++ id))) - send $ - responseLBS - HttpTypes.status200 - [("Content-Type", "application/json; charset=utf-8")] - (L.fromStrict responseBody) - _ -> - send $ - responseLBS - (HttpTypes.mkStatus responseStatusCode responseStatusMessage) - [("Content-Type", "application/json; charset=utf-8")] - (L.fromStrict responseBody) - -postApi :: [HttpTypes.Header] -> Network.Wai.Parse.FileInfo c -> String -> String -> IO (S8.ByteString, Int, S8.ByteString) -postApi allHeaders file restUrl fileId = runReq (defaultHttpConfig {httpConfigCheckResponse = httpConfigDontCheckResponse}) $ do - let payload = - object - [ "name" .= S8.unpack (getOneHeader allHeaders "X-FF-NAME"), -- name and path are taken from headers - "path" .= S8.unpack (getOneHeader allHeaders "X-FF-PATH"), -- because they could have been change by the user in the frontend - "mimeType" .= S8.unpack (fileContentType file), - "size" .= S8.unpack (getOneHeader allHeaders "X-FF-SIZE") - ] - - r <- - req - POST -- method - --(http (DataText.pack restUrl) /: "t/os3vu-1615111052/post") - (http (DataText.pack restUrl) /: "api" /: "v1" /: "filesystem" /: DataText.pack fileId /: "upload") - (ReqBodyJson payload) -- use built-in options or add your own - bsResponse -- specify how to interpret response - (header "Authorization" (getOneHeader allHeaders "Authorization") <> port 8080) - return (responseBody r, responseStatusCode r, responseStatusMessage r) - -download :: Application -download req send = do - let headers = requestHeaders req - queryParam = getDownloadQuery $ queryString req - redirectOnError = True --todo: make this a query param or something - case queryParam of - Nothing -> - send $ - responseLBS - HttpTypes.status501 - [("Content-Type", "application/json; charset=utf-8")] - "No ids parameter supplied." - Just param -> do - restUrl <- getRestUrl - logStdOut "download" - (responseBody, responseStatusCode, responseStatusMessage, fileNameHeader) <- getApi headers param restUrl - case (responseStatusCode, redirectOnError) 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 - files -> - withSystemTempFile "FileFighterFileHandler.zip" $ - \tmpFileName handle -> - do - let nameOfTheFolder = fromMaybe "Files" fileNameHeader - let ss = - mapM - ( \file -> do - inZipPath <- mkEntrySelector $ fromMaybe (name file) (path file) -- either take the filename or path - loadEntry Deflate inZipPath (getPathFromFileId (show $ fileSystemId file)) - ) - files - createArchive tmpFileName ss - send $ - responseFile - HttpTypes.status200 - [ ("Content-Disposition", S8.pack ("attachment; filename=\"" ++ S8.unpack nameOfTheFolder ++ ".zip" ++ "\"")), - ("Content-Type", "application/zip") - ] - tmpFileName - Nothing - (_, True) -> do - let decoded = (eitherDecode $ L.fromStrict responseBody) :: (Either String RestApiStatus) - case decoded of - Left err -> - send $ - responseLBS - HttpTypes.status500 - [("Content-Type", "application/json; charset=utf-8")] - (encode $ RestApiStatus err "Internal Server Error") - Right status -> - let location = - "/error?dest=" - <> HttpTypes.urlEncode True (rawPathInfo req) - <> HttpTypes.urlEncode True (rawQueryString req) - <> "&message=" - <> HttpTypes.urlEncode True (S8.pack $ message status) - in send $ responseLBS HttpTypes.status303 [("Location", location)] "" - (_, False) -> - send $ - responseLBS - (HttpTypes.mkStatus responseStatusCode responseStatusMessage) - [("Content-Type", "application/json; charset=utf-8")] - (L.fromStrict responseBody) - -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) /: "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 "Cookie" (getOneHeader allHeaders "Cookie") <> port 8080 <> (=:) "ids" param) --PORT !! - -- mempty -- query params, headers, explicit port number, etc. - liftIO $ logStdOut $ show (getOneHeader allHeaders "Cookie") - return (responseBody r, responseStatusCode r, responseStatusMessage r, responseHeader r "X-FF-NAME") - -preview :: Application -preview req send = do - let headers = requestHeaders req - id = pathInfo req !! 2 - redirectOnError = True --todo: make this a query param or something - restUrl <- getRestUrl - (responseBody, responseStatusCode, responseStatusMessage) <- previewApi headers id restUrl - logStdOut $ S8.unpack responseStatusMessage - case (responseStatusCode, redirectOnError) of - (200, _) -> do - let decoded = (eitherDecode $ L.fromStrict responseBody) :: (Either String RestResponseFile) - case decoded of - Left err -> - send $ - responseLBS - HttpTypes.status500 - [("Content-Type", "application/json; charset=utf-8")] - (encode $ RestApiStatus err "Internal Server Error") - Right file -> - let fileID = fileSystemId file - fileMimeType = fromMaybe "application/octet-stream" (mimeType file) - path = getPathFromFileId $ show fileID - in send $ - responseFile - HttpTypes.status200 - [("Content-Type", S8.pack fileMimeType)] - path - Nothing - (_, True) -> do - let decoded = (eitherDecode $ L.fromStrict responseBody) :: (Either String RestApiStatus) - case decoded of - Left err -> - send $ - responseLBS - HttpTypes.status500 - [("Content-Type", "application/json; charset=utf-8")] - (encode $ RestApiStatus err "Internal Server Error") - Right status -> - let location = - "/error?dest=" <> HttpTypes.urlEncode True (rawPathInfo req) - <> "&message=" - <> HttpTypes.urlEncode True (S8.pack $ message status) - in send $ responseLBS HttpTypes.status303 [("Location", location)] "" - (_, False) -> - send $ - responseLBS - (HttpTypes.mkStatus responseStatusCode responseStatusMessage) - [("Content-Type", "application/json; charset=utf-8")] - (L.fromStrict responseBody) - -previewApi :: [HttpTypes.Header] -> DataText.Text -> String -> IO (S8.ByteString, Int, S8.ByteString) -previewApi allHeaders id restUrl = runReq (defaultHttpConfig {httpConfigCheckResponse = httpConfigDontCheckResponse}) $ do - r <- - req - GET -- method - (http (DataText.pack restUrl) /: "api" /: "v1" /: "filesystem" /: id /: "info") -- safe by construction URL - --(http (DataText.pack restUrl) /: "v1" /: "filesystem" /: id /: "info" ) -- safe by construction URL - NoReqBody -- use built-in options or add your own - bsResponse -- specify how to interpret response - (header "Cookie" (getOneHeader allHeaders "Cookie") <> port 8080) --PORT !! - -- mempty -- query params, headers, explicit port number, etc. - liftIO $ logStdOut "Requested fileinfo" - return (responseBody r, responseStatusCode r, responseStatusMessage r) - -delete :: Application -delete req send = do - logStdOut "requesting delete" - let headers = requestHeaders req - restUrl <- getRestUrl - (responseBody, responseStatusCode, responseStatusMessage) <- deleteApi headers restUrl (DataText.unpack $ pathInfo req !! 2) - case responseStatusCode of - 200 -> do - let d = (eitherDecode $ L.fromStrict responseBody) :: (Either String [RestResponseFile]) - case d of - Left err -> - send $ - responseLBS - HttpTypes.status500 - [("Content-Type", "application/json; charset=utf-8")] - (encode $ RestApiStatus err "Internal Server Error") - Right fileObjects -> do - mapM_ deleteFile (filter filterFiles fileObjects) - send $ - responseLBS - HttpTypes.status200 - [("Content-Type", "application/json; charset=utf-8")] - (L.fromStrict responseBody) - _ -> - send $ - responseLBS - (HttpTypes.mkStatus responseStatusCode responseStatusMessage) - [("Content-Type", "application/json; charset=utf-8")] - (L.fromStrict responseBody) - -deleteApi :: [HttpTypes.Header] -> String -> String -> IO (S8.ByteString, Int, S8.ByteString) -deleteApi allHeaders restUrl fileId = runReq (defaultHttpConfig {httpConfigCheckResponse = httpConfigDontCheckResponse}) $ do - r <- - req - 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 - return (responseBody r, responseStatusCode r, responseStatusMessage r) - -health :: Application -health req send = do - deploymentType <- getDeploymentType - files <- concat <$> (mapM listDirectoryRelative =<< (filterM doesDirectoryExist =<< listDirectory ".")) - actualFilesSize <- sum <$> mapM getFileSize files - - let response = - object - [ "version" .= ("0.2.1" :: String), - "deploymentType" .= deploymentType, - "actualFilesSize" .= actualFilesSize, - "fileCount" .= length files - ] - send $ - responseLBS - HttpTypes.status200 - [("Content-Type", "application/json; charset=utf-8")] - (encode response) - -getOneHeader :: [HttpTypes.Header] -> String -> S8.ByteString -getOneHeader headers headerName = - case Prelude.filter (\n -> fst n == (Data.CaseInsensitive.mk (S8.pack headerName) :: CI S8.ByteString)) headers of - [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 - putStrLn text - hFlush stdout - -deleteFile :: RestResponseFile -> IO () -deleteFile file = removeFile $ getPathFromFileId (show $ fileSystemId file) - -filterFiles :: RestResponseFile -> Bool -filterFiles file = case filesystemType file of - "FOLDER" -> False - _ -> True - -httpConfigDontCheckResponse :: p1 -> p2 -> p3 -> Maybe a -httpConfigDontCheckResponse _ _ _ = Nothing - -data RestApiStatus = RestApiStatus - { message :: !String, - status :: !String - } - deriving (Show, Generic) - -instance FromJSON RestApiStatus - -instance ToJSON RestApiStatus - -devCorsPolicy = - Just - CorsResourcePolicy - { corsOrigins = Nothing, - corsMethods = ["GET", "POST", "DELETE"], - corsRequestHeaders = ["Authorization", "content-type", "X-FF-IDS", "X-FF-ID", "X-FF-NAME", "X-FF-PATH", "X-FF-SIZE"], - corsExposedHeaders = Just ["Content-Disposition"], - corsMaxAge = Just $ 60 * 60 * 24, -- one day - corsVaryOrigin = False, - corsRequireOrigin = False, - corsIgnoreFailures = False - } - -getRestUrl :: IO String -getRestUrl = head <$> getArgs - -getDeploymentType :: IO String -getDeploymentType = head . tail <$> getArgs - -data User = User - { userId :: Int, - username :: String, - groups :: [String] - } - deriving (Show, Generic) - -instance FromJSON User - -instance ToJSON User - -data RestResponseFile = RestResponseFile - { fileSystemId :: !Int, - name :: String, - path :: Maybe String, - size :: Int, - owner :: User, - lastUpdatedBy :: User, - lastUpdated :: Int, - mimeType :: Maybe String, - filesystemType :: String, - shared :: Bool - } - deriving (Show, Generic) - -instance FromJSON RestResponseFile where - parseJSON = - genericParseJSON - defaultOptions - { fieldLabelModifier = typeFieldRename, - omitNothingFields = True - } - -listDirectoryRelative :: FilePath -> IO [FilePath] -listDirectoryRelative x = Prelude.map (x ) <$> listDirectory x \ No newline at end of file +main = warp 3000 App diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000..63cbe03 --- /dev/null +++ b/package.yaml @@ -0,0 +1,38 @@ +name: FileHandlerYesod +version: "0.1.0" + +dependencies: +- base +- yesod-core +- http-types +- bytestring +- aeson +- wai +- wai-extra +- text +- req +- zip +- temporary +- case-insensitive +- resourcet +- mtl +- directory +- filepath + + +# The library contains all of our application code. The executable +# defined below is just a thin wrapper. +library: + source-dirs: src + +# Runnable executable for our application +executables: + FileHandlerYesod: + main: Main.hs + source-dirs: app + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + dependencies: + - FileHandlerYesod diff --git a/routes.yesodroutes b/routes.yesodroutes new file mode 100644 index 0000000..7756ccf --- /dev/null +++ b/routes.yesodroutes @@ -0,0 +1,6 @@ +/ HomeR GET +/data/download DownloadR GET +/data/upload UploadR POST +/data/delete/#Int DeleteR DELETE +/data/preview/#Int PreviewR GET +/data/health HealthR GET diff --git a/src/Application.hs b/src/Application.hs new file mode 100644 index 0000000..16fce18 --- /dev/null +++ b/src/Application.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Application where + +import Foundation +import Yesod.Core + +import Handler.Home +import Handler.Download +import Handler.Upload +import Handler.Delete +import Handler.Preview +import Handler.Health + +mkYesodDispatch "App" resourcesApp diff --git a/src/Foundation.hs b/src/Foundation.hs new file mode 100644 index 0000000..8ae4ca2 --- /dev/null +++ b/src/Foundation.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +module Foundation where + +import Yesod.Core + +data App = App + +mkYesodData "App" $(parseRoutesFile "routes.yesodroutes") + +instance Yesod App diff --git a/src/Handler/Delete.hs b/src/Handler/Delete.hs new file mode 100644 index 0000000..4f304d0 --- /dev/null +++ b/src/Handler/Delete.hs @@ -0,0 +1,71 @@ +-- | + +{-# LANGUAGE OverloadedStrings #-} +module Handler.Delete where +import Foundation +import Yesod.Core + + +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as L +import qualified Network.HTTP.Types as HttpTypes +import qualified Data.Text as DataText +import Data.Aeson +import Data.Maybe (fromMaybe) +import Models.Inode +import Network.HTTP.Req +import Utils.RequestUtils +import Network.Wai +import Utils.FileUtils +import Logger +import Models.RestApiStatus +import System.Directory + + + +deleteDeleteR :: Int -> Handler () +deleteDeleteR _ = + sendWaiApplication delete +delete :: Application +delete req send = do + logStdOut "requesting delete" + let headers = requestHeaders req + restUrl <- getRestUrl + (responseBody, responseStatusCode, responseStatusMessage) <- deleteApi headers restUrl (DataText.unpack $ pathInfo req !! 2) + case responseStatusCode of + 200 -> do + let d = (eitherDecode $ L.fromStrict responseBody) :: (Either String [Inode]) + case d of + Left err -> + send $ + responseLBS + HttpTypes.status500 + [("Content-Type", "application/json; charset=utf-8")] + (encode $ RestApiStatus err "Internal Server Error") + Right fileObjects -> do + mapM_ deleteFile (filter filterFiles fileObjects) + send $ + responseLBS + HttpTypes.status200 + [("Content-Type", "application/json; charset=utf-8")] + (L.fromStrict responseBody) + _ -> + send $ + responseLBS + (HttpTypes.mkStatus responseStatusCode responseStatusMessage) + [("Content-Type", "application/json; charset=utf-8")] + (L.fromStrict responseBody) + +deleteApi :: [HttpTypes.Header] -> String -> String -> IO (S8.ByteString, Int, S8.ByteString) +deleteApi allHeaders restUrl fileId = runReq (defaultHttpConfig {httpConfigCheckResponse = httpConfigDontCheckResponse}) $ do + r <- + req + 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 + return (responseBody r, responseStatusCode r, responseStatusMessage r) + +deleteFile :: Inode -> IO () +deleteFile file = removeFile $ getPathFromFileId (show $ fileSystemId file) diff --git a/src/Handler/Download.hs b/src/Handler/Download.hs new file mode 100644 index 0000000..67ec11b --- /dev/null +++ b/src/Handler/Download.hs @@ -0,0 +1,142 @@ + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +module Handler.Download where + +import Foundation +import Yesod.Core + + +import Network.Wai +import Codec.Archive.Zip + +import qualified Network.HTTP.Types as HttpTypes +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as L +import qualified Data.Text as DataText +import Data.Maybe +import Data.CaseInsensitive + +import Network.HTTP.Req +import System.Environment +import System.IO.Temp + + + + +import Models.Inode +import Models.RestApiStatus + +import Utils.RequestUtils +import Utils.FileUtils + +import Logger +import Data.Aeson + +getDownloadR :: Handler () +getDownloadR = + sendWaiApplication download + +download :: Application +download req send = do + let headers = requestHeaders req + queryParam = getDownloadQuery $ queryString req + redirectOnError = True --todo: make this a query param or something + case queryParam of + Nothing -> + send $ + responseLBS + HttpTypes.status501 + [("Content-Type", "application/json; charset=utf-8")] + "No ids parameter supplied." + Just param -> do + restUrl <- getRestUrl + logStdOut "download" + (responseBody, responseStatusCode, responseStatusMessage, fileNameHeader) <- getApi headers param restUrl + case (responseStatusCode, redirectOnError) of + (200, _) -> do + let d = (eitherDecode $ L.fromStrict responseBody) :: (Either String [Inode]) + 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 + files -> + withSystemTempFile "FileFighterFileHandler.zip" $ + \tmpFileName handle -> + do + let nameOfTheFolder = fromMaybe "Files" fileNameHeader + let ss = + mapM + ( \file -> do + inZipPath <- mkEntrySelector $ fromMaybe (name file) (path file) -- either take the filename or path + loadEntry Deflate inZipPath (getPathFromFileId (show $ fileSystemId file)) + ) + files + createArchive tmpFileName ss + send $ + responseFile + HttpTypes.status200 + [ ("Content-Disposition", S8.pack ("attachment; filename=\"" ++ S8.unpack nameOfTheFolder ++ ".zip" ++ "\"")), + ("Content-Type", "application/zip") + ] + tmpFileName + Nothing + (_, True) -> do + let decoded = (eitherDecode $ L.fromStrict responseBody) :: (Either String RestApiStatus) + case decoded of + Left err -> + send $ + responseLBS + HttpTypes.status500 + [("Content-Type", "application/json; charset=utf-8")] + (encode $ RestApiStatus err "Internal Server Error") + Right status -> + let location = + "/error?dest=" + <> HttpTypes.urlEncode True (rawPathInfo req) + <> HttpTypes.urlEncode True (rawQueryString req) + <> "&message=" + <> HttpTypes.urlEncode True (S8.pack $ message status) + in send $ responseLBS HttpTypes.status303 [("Location", location)] "" + (_, False) -> + send $ + responseLBS + (HttpTypes.mkStatus responseStatusCode responseStatusMessage) + [("Content-Type", "application/json; charset=utf-8")] + (L.fromStrict responseBody) + +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) /: "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 "Cookie" (getOneHeader allHeaders "Cookie") <> port 8080 <> (=:) "ids" param) --PORT !! + -- mempty -- query params, headers, explicit port number, etc. + liftIO $ logStdOut $ show (getOneHeader allHeaders "Cookie") + return (responseBody r, responseStatusCode r, responseStatusMessage r, responseHeader r "X-FF-NAME") + +getDownloadQuery :: HttpTypes.Query -> Maybe String +getDownloadQuery [(param, Just value)] = if param == "ids" then Just (S8.unpack value) else Nothing +getDownloadQuery _ = Nothing diff --git a/src/Handler/Health.hs b/src/Handler/Health.hs new file mode 100644 index 0000000..15c5bf2 --- /dev/null +++ b/src/Handler/Health.hs @@ -0,0 +1,35 @@ +-- | +{-# LANGUAGE OverloadedStrings #-} + +module Handler.Health where + +import Foundation +import Yesod.Core +import qualified Network.HTTP.Types as HttpTypes +import Network.Wai +import Data.Aeson +import System.Environment +import System.Directory +import System.FilePath +import Control.Monad + +getHealthR :: Handler Value +getHealthR = do + deploymentType <- liftIO getDeploymentType + files <- liftIO $ concat <$> (mapM listDirectoryRelative =<< (filterM doesDirectoryExist =<< listDirectory ".")) + actualFilesSize <- liftIO $ sum <$> mapM getFileSize files + let response = + object + [ "version" .= ("0.2.1" :: String), + "deploymentType" .= deploymentType, + "actualFilesSize" .= actualFilesSize, + "fileCount" .= length files + ] + return response + + +getDeploymentType :: IO String +getDeploymentType = head . tail <$> getArgs + +listDirectoryRelative :: FilePath -> IO [FilePath] +listDirectoryRelative x = Prelude.map (x ) <$> listDirectory x diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs new file mode 100644 index 0000000..2d77e84 --- /dev/null +++ b/src/Handler/Home.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +module Handler.Home where + +import Foundation +import Yesod.Core + + + +getHomeR :: Handler String +getHomeR = + return "hallo" diff --git a/src/Handler/Preview.hs b/src/Handler/Preview.hs new file mode 100644 index 0000000..e8a14b7 --- /dev/null +++ b/src/Handler/Preview.hs @@ -0,0 +1,93 @@ +-- | +{-# LANGUAGE OverloadedStrings #-} + +module Handler.Preview where +import Foundation +import Yesod.Core + + +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as L +import qualified Network.HTTP.Types as HttpTypes +import qualified Data.Text as DataText +import Data.Aeson +import Data.Maybe (fromMaybe) + + + + +import Models.Inode +import Models.RestApiStatus +import Utils.RequestUtils +import Logger +import Network.HTTP.Req +import Network.Wai +import Utils.FileUtils + +getPreviewR :: Int -> Handler () +getPreviewR _ = + sendWaiApplication preview + +preview :: Application +preview req send = do + let headers = requestHeaders req + id = pathInfo req !! 2 + redirectOnError = True --todo: make this a query param or something + restUrl <- getRestUrl + (responseBody, responseStatusCode, responseStatusMessage) <- previewApi headers id restUrl + logStdOut $ S8.unpack responseStatusMessage + case (responseStatusCode, redirectOnError) of + (200, _) -> do + let decoded = (eitherDecode $ L.fromStrict responseBody) :: (Either String Inode) + case decoded of + Left err -> + send $ + responseLBS + HttpTypes.status500 + [("Content-Type", "application/json; charset=utf-8")] + (encode $ RestApiStatus err "Internal Server Error") + Right file -> + let fileID = fileSystemId file + fileMimeType = fromMaybe "application/octet-stream" (mimeType file) + path = getPathFromFileId $ show fileID + in send $ + responseFile + HttpTypes.status200 + [("Content-Type", S8.pack fileMimeType)] + path + Nothing + (_, True) -> do + let decoded = (eitherDecode $ L.fromStrict responseBody) :: (Either String RestApiStatus) + case decoded of + Left err -> + send $ + responseLBS + HttpTypes.status500 + [("Content-Type", "application/json; charset=utf-8")] + (encode $ RestApiStatus err "Internal Server Error") + Right status -> + let location = + "/error?dest=" <> HttpTypes.urlEncode True (rawPathInfo req) + <> "&message=" + <> HttpTypes.urlEncode True (S8.pack $ message status) + in send $ responseLBS HttpTypes.status303 [("Location", location)] "" + (_, False) -> + send $ + responseLBS + (HttpTypes.mkStatus responseStatusCode responseStatusMessage) + [("Content-Type", "application/json; charset=utf-8")] + (L.fromStrict responseBody) + +previewApi :: [HttpTypes.Header] -> DataText.Text -> String -> IO (S8.ByteString, Int, S8.ByteString) +previewApi allHeaders id restUrl = runReq (defaultHttpConfig {httpConfigCheckResponse = httpConfigDontCheckResponse}) $ do + r <- + req + GET -- method + (http (DataText.pack restUrl) /: "api" /: "v1" /: "filesystem" /: id /: "info") -- safe by construction URL + --(http (DataText.pack restUrl) /: "v1" /: "filesystem" /: id /: "info" ) -- safe by construction URL + NoReqBody -- use built-in options or add your own + bsResponse -- specify how to interpret response + (header "Cookie" (getOneHeader allHeaders "Cookie") <> port 8080) --PORT !! + -- mempty -- query params, headers, explicit port number, etc. + liftIO $ logStdOut "Requested fileinfo" + return (responseBody r, responseStatusCode r, responseStatusMessage r) diff --git a/src/Handler/Upload.hs b/src/Handler/Upload.hs new file mode 100644 index 0000000..b7e515d --- /dev/null +++ b/src/Handler/Upload.hs @@ -0,0 +1,109 @@ +-- | +{-# LANGUAGE OverloadedStrings #-} + +module Handler.Upload where + + +import Network.Wai +import Network.Wai.Parse + +import qualified Network.HTTP.Types as HttpTypes +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as L +import qualified Data.Text as DataText +import Control.Monad.State +import Control.Monad.Trans.Resource +import Network.HTTP.Req +import Data.CaseInsensitive +import System.Directory + +import Models.Inode +import Utils.RequestUtils +import Utils.FileUtils +import Data.Aeson +import Models.RestApiStatus +import Logger +import Foundation +import Yesod.Core hiding (fileContentType) + +postUploadR :: Handler () +postUploadR = + sendWaiApplication upload + +upload :: Application +upload req send = runResourceT $ + withInternalState $ + \internalState -> + do + (_params, files) <- parseRequestBody (tempFileBackEnd internalState) req + let headers = requestHeaders req + -- debug (_params) + -- Look for the file parameter called "file" + case lookup "file" files of + -- Not found, so return a 400 response + Nothing -> + send $ + responseLBS + HttpTypes.status400 + [("Content-Type", "application/json; charset=utf-8")] + (encode $ RestApiStatus "No file parameter found" "Bad Request") + -- Got it! + Just file -> do + let content = fileContent file + restUrl <- getRestUrl + (responseBody, responseStatusCode, responseStatusMessage) <- postApi headers file restUrl (DataText.unpack $ pathInfo req !! 2) + case responseStatusCode of + 201 -> do + let d = (eitherDecode $ L.fromStrict responseBody) :: (Either String [Inode]) + case d of + Left err -> + send $ + responseLBS + HttpTypes.status500 + [("Content-Type", "application/json; charset=utf-8")] + (encode $ RestApiStatus err "Internal Server Error") + Right filesAndFolders -> + case filter filterFiles filesAndFolders of + [] -> + send $ + responseLBS + HttpTypes.status500 + [("Content-Type", "application/json; charset=utf-8")] + (encode $ RestApiStatus "No file found in rest response." "Internal Server Error") + [file] -> do + let id = show $ fileSystemId file + createDirectoryIfMissing True [head id] + copyFile content (getPathFromFileId id) + logStdOut ("Uploaded " ++ (head id : ("/" ++ id))) + send $ + responseLBS + HttpTypes.status200 + [("Content-Type", "application/json; charset=utf-8")] + (L.fromStrict responseBody) + _ -> + send $ + responseLBS + (HttpTypes.mkStatus responseStatusCode responseStatusMessage) + [("Content-Type", "application/json; charset=utf-8")] + (L.fromStrict responseBody) + +postApi :: [HttpTypes.Header] -> Network.Wai.Parse.FileInfo c -> String -> String -> IO (S8.ByteString, Int, S8.ByteString) +postApi allHeaders file restUrl fileId = runReq (defaultHttpConfig {httpConfigCheckResponse = httpConfigDontCheckResponse}) $ do + let payload = + object + [ "name" .= S8.unpack (getOneHeader allHeaders "X-FF-NAME"), -- name and path are taken from headers + "path" .= S8.unpack (getOneHeader allHeaders "X-FF-PATH"), -- because they could have been change by the user in the frontend + "mimeType" .= S8.unpack (fileContentType file), + "size" .= S8.unpack (getOneHeader allHeaders "X-FF-SIZE") + ] + + r <- + req + POST -- method + --(http (DataText.pack restUrl) /: "t/os3vu-1615111052/post") + (http (DataText.pack restUrl) /: "api" /: "v1" /: "filesystem" /: DataText.pack fileId /: "upload") + (ReqBodyJson payload) -- use built-in options or add your own + bsResponse -- specify how to interpret response + (header "Authorization" (getOneHeader allHeaders "Authorization") <> port 8080) + return (responseBody r, responseStatusCode r, responseStatusMessage r) + diff --git a/src/Lib.hs b/src/Lib.hs deleted file mode 100644 index e356dcb..0000000 --- a/src/Lib.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Lib - ( typeFieldRename, getPathFromFileId - ) where - - - -typeFieldRename :: String -> String -typeFieldRename "filesystemType" = "type" -typeFieldRename "type" = "filesystemType" -typeFieldRename name = name - - - -getPathFromFileId :: String -> String -getPathFromFileId id=head id : ("/" ++id) diff --git a/src/Logger.hs b/src/Logger.hs new file mode 100644 index 0000000..590b076 --- /dev/null +++ b/src/Logger.hs @@ -0,0 +1,9 @@ +-- | + +module Logger where +import System.IO (hFlush, stdout) + +logStdOut :: String -> IO () +logStdOut text = do + putStrLn text + hFlush stdout diff --git a/src/Models/Inode.hs b/src/Models/Inode.hs new file mode 100644 index 0000000..b9c8f4f --- /dev/null +++ b/src/Models/Inode.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE DeriveGeneric #-} +module Models.Inode where + + +import Data.Aeson +import GHC.Generics + +import Models.User + +data Inode = Inode + { fileSystemId :: !Int, + name :: String, + path :: Maybe String, + size :: Int, + owner :: User, + lastUpdatedBy :: User, + lastUpdated :: Int, + mimeType :: Maybe String, + filesystemType :: String, + shared :: Bool + } + deriving (Show, Generic) + +typeFieldRename :: String -> String +typeFieldRename "filesystemType" = "type" +typeFieldRename "type" = "filesystemType" +typeFieldRename name = name + +instance FromJSON Inode where + parseJSON = + genericParseJSON + defaultOptions + { fieldLabelModifier = typeFieldRename, + omitNothingFields = True + } diff --git a/src/Models/RestApiStatus.hs b/src/Models/RestApiStatus.hs new file mode 100644 index 0000000..a83f686 --- /dev/null +++ b/src/Models/RestApiStatus.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DeriveGeneric #-} +-- | + +module Models.RestApiStatus where + +import Data.Aeson +import GHC.Generics + +data RestApiStatus = RestApiStatus + { message :: !String, + status :: !String + } + deriving (Show, Generic) + +instance FromJSON RestApiStatus + +instance ToJSON RestApiStatus diff --git a/src/Models/User.hs b/src/Models/User.hs new file mode 100644 index 0000000..a7d661c --- /dev/null +++ b/src/Models/User.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Models.User where +import Data.Aeson +import GHC.Generics + +data User = User + { userId :: Int, + username :: String, + groups :: [String] + } + deriving (Show, Generic) + +instance FromJSON User + +instance ToJSON User diff --git a/src/Utils/FileUtils.hs b/src/Utils/FileUtils.hs new file mode 100644 index 0000000..72ebcb9 --- /dev/null +++ b/src/Utils/FileUtils.hs @@ -0,0 +1,12 @@ +-- | + +module Utils.FileUtils where +import Models.Inode + +getPathFromFileId :: String -> String +getPathFromFileId id=head id : ("/" ++id) + +filterFiles :: Inode -> Bool +filterFiles file = case filesystemType file of + "FOLDER" -> False + _ -> True diff --git a/src/Utils/FileUtils.sh b/src/Utils/FileUtils.sh new file mode 100644 index 0000000..f1f641a --- /dev/null +++ b/src/Utils/FileUtils.sh @@ -0,0 +1 @@ +#!/usr/bin/env bash diff --git a/src/Utils/RequestUtils.hs b/src/Utils/RequestUtils.hs new file mode 100644 index 0000000..d185d65 --- /dev/null +++ b/src/Utils/RequestUtils.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE OverloadedStrings #-} + + +module Utils.RequestUtils where + +import qualified Data.ByteString.Char8 as S8 +import qualified Network.HTTP.Types as HttpTypes +import Data.CaseInsensitive +import System.Environment + +getOneHeader :: [HttpTypes.Header] -> String -> S8.ByteString +getOneHeader headers headerName = + case Prelude.filter (\n -> fst n == (Data.CaseInsensitive.mk (S8.pack headerName) :: CI S8.ByteString)) headers of + [header] -> snd header + _ -> "" +httpConfigDontCheckResponse :: p1 -> p2 -> p3 -> Maybe a +httpConfigDontCheckResponse _ _ _ = Nothing + +getRestUrl :: IO String +getRestUrl = head <$> getArgs diff --git a/stack.yaml b/stack.yaml index c5ef460..1b0ab22 100644 --- a/stack.yaml +++ b/stack.yaml @@ -18,7 +18,7 @@ # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml resolver: - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/5.yaml + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/23.yaml # User packages to be built. # Various formats can be used as shown in the example below. @@ -40,23 +40,7 @@ packages: # - git: https://github.com/commercialhaskell/stack.git # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a # -#extra-deps: -#- req -#- shakespeare -#- wai -#- wai-app-static -#- wai-extra -#- warp -#- network -#- text -#- aeson -#- filepath -#- http-types -#- bytestring -#- directory -#- text -#- case-insensitive -#- blaze-html +# extra-deps: [] # Override default flag values for local packages and extra-deps # flags: {} @@ -69,7 +53,7 @@ packages: # # Require a specific version of stack, using version ranges # require-stack-version: -any # Default -# require-stack-version: ">=2.5" +# require-stack-version: ">=2.7" # # Override the architecture used by stack, especially useful on Windows # arch: i386 diff --git a/stack.yaml.lock b/stack.yaml.lock index 9d3217f..56a0f91 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -6,8 +6,8 @@ packages: [] snapshots: - completed: - size: 565266 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/5.yaml - sha256: 78e8ebabf11406261abbc95b44f240acf71802630b368888f6d758de7fc3a2f7 + sha256: 7f69bb29a57495586e7e3ed31ecc59c0d2c959cb23bd52b71ca676f254c9beb1 + size: 587819 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/23.yaml original: - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/5.yaml + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/23.yaml diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 index 7df5105..0000000 --- a/test/Spec.hs +++ /dev/null @@ -1,18 +0,0 @@ -import Test.Hspec -import Test.QuickCheck -import Control.Exception (evaluate) -import Lib - -main :: IO () -main = hspec $ - describe "getPathFromFileId" $ do - it "returns the first element of a list" $ - getPathFromFileId "34535345" `shouldBe` "3/34535345" - - it "returns the first element of an *arbitrary* list" $ - property $ \x xs -> head (x:xs) == (x :: Int) - - it "throws an exception if used with an empty list" $ - evaluate (head []) `shouldThrow` anyException - - \ No newline at end of file From 60d10683903fa98df3e44b45cdea82ddcaeac6b1 Mon Sep 17 00:00:00 2001 From: qvalentin Date: Sat, 29 Jan 2022 12:31:00 +0100 Subject: [PATCH 02/35] use correct typing for health endpoint --- src/Handler/Health.hs | 32 +++++++++++++++++++------------- 1 file changed, 19 insertions(+), 13 deletions(-) diff --git a/src/Handler/Health.hs b/src/Handler/Health.hs index 15c5bf2..5d489cc 100644 --- a/src/Handler/Health.hs +++ b/src/Handler/Health.hs @@ -1,33 +1,39 @@ --- | {-# LANGUAGE OverloadedStrings #-} +-- | module Handler.Health where +import Control.Monad +import Data.Aeson import Foundation -import Yesod.Core import qualified Network.HTTP.Types as HttpTypes import Network.Wai -import Data.Aeson -import System.Environment import System.Directory +import System.Environment import System.FilePath -import Control.Monad +import Yesod.Core + +data HealthInfo = HealthInfo + { version :: String, + deploymentType :: String, + actualFilesSize :: Integer, + fileCount :: Int + } -getHealthR :: Handler Value +getHealthR :: Handler HealthInfo getHealthR = do deploymentType <- liftIO getDeploymentType files <- liftIO $ concat <$> (mapM listDirectoryRelative =<< (filterM doesDirectoryExist =<< listDirectory ".")) actualFilesSize <- liftIO $ sum <$> mapM getFileSize files let response = - object - [ "version" .= ("0.2.1" :: String), - "deploymentType" .= deploymentType, - "actualFilesSize" .= actualFilesSize, - "fileCount" .= length files - ] + HealthInfo + { version = "0.2.1" :: String, + deploymentType = deploymentType, + actualFilesSize = actualFilesSize, + fileCount = length files + } return response - getDeploymentType :: IO String getDeploymentType = head . tail <$> getArgs From 15dd3ec967f8676875b1d2efeef6749eb3e2a9b3 Mon Sep 17 00:00:00 2001 From: qvalentin Date: Tue, 1 Feb 2022 20:23:55 +0100 Subject: [PATCH 03/35] delte Endpoint migated, upload WIP --- app/Main.hs | 5 +- package.yaml | 8 ++ routes.yesodroutes | 2 +- src/Application.hs | 45 +++++++--- src/Foundation.hs | 7 +- src/Handler/Delete.hs | 68 +++++---------- src/Handler/Health.hs | 43 +++++---- src/Handler/Upload.hs | 196 ++++++++++++++++++++++++------------------ stack.yaml | 3 +- stack.yaml.lock | 8 +- 10 files changed, 218 insertions(+), 167 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 5ed9ac4..68a03c8 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,6 +1,5 @@ -import Application () -- for YesodDispatch instance import Foundation -import Yesod.Core +import Application (appMain) main :: IO () -main = warp 3000 App +main = appMain diff --git a/package.yaml b/package.yaml index 63cbe03..aa85925 100644 --- a/package.yaml +++ b/package.yaml @@ -3,12 +3,17 @@ version: "0.1.0" dependencies: - base +- yesod - yesod-core +- classy-prelude >=1.5 && <1.6 +- classy-prelude-conduit >=1.5 && <1.6 +- classy-prelude-yesod >=1.5 && <1.6 - http-types - bytestring - aeson - wai - wai-extra +- warp - text - req - zip @@ -18,6 +23,9 @@ dependencies: - mtl - directory - filepath +- yaml +- file-embed + # The library contains all of our application code. The executable diff --git a/routes.yesodroutes b/routes.yesodroutes index 7756ccf..1929826 100644 --- a/routes.yesodroutes +++ b/routes.yesodroutes @@ -1,6 +1,6 @@ / HomeR GET /data/download DownloadR GET -/data/upload UploadR POST +/data/upload/#Int UploadR POST /data/delete/#Int DeleteR DELETE /data/preview/#Int PreviewR GET /data/health HealthR GET diff --git a/src/Application.hs b/src/Application.hs index 16fce18..d3c093d 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -1,18 +1,43 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE ViewPatterns #-} - +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + module Application where +import Data.Yaml.Config +import FileSystemServiceClient.FileSystemServiceClient (makeFileSystemServiceClient) import Foundation -import Yesod.Core - -import Handler.Home -import Handler.Download -import Handler.Upload import Handler.Delete -import Handler.Preview +import Handler.Download import Handler.Health +import Handler.Home +import Handler.Preview +import Handler.Upload +import Settings +import Yesod.Core mkYesodDispatch "App" resourcesApp + +makeFoundation :: AppSettings -> IO App +makeFoundation appSettings = do + let fssC = makeFileSystemServiceClient (fileSystemServiceSettings appSettings) + return + App + { appSettings = appSettings, + fileSystemServiceClient = fssC + } + +appMain :: IO () +appMain = do + -- Get the settings from all relevant sources + settings <- + loadYamlSettingsArgs + -- fall back to compile-time values, set to [] to require values at runtime + [configSettingsYmlValue] + -- allow environment variables to override + useEnv + + app <- makeFoundation settings + + warp 5000 app diff --git a/src/Foundation.hs b/src/Foundation.hs index 8ae4ca2..ca43ebe 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -5,9 +5,14 @@ module Foundation where import Yesod.Core +import Settings (AppSettings) +import FileSystemServiceClient.FileSystemServiceClient data App = App + { appSettings :: AppSettings + , fileSystemServiceClient :: FileSystemServiceClient + } mkYesodData "App" $(parseRoutesFile "routes.yesodroutes") -instance Yesod App +instance Yesod App where diff --git a/src/Handler/Delete.hs b/src/Handler/Delete.hs index 4f304d0..c83999d 100644 --- a/src/Handler/Delete.hs +++ b/src/Handler/Delete.hs @@ -1,14 +1,10 @@ -- | - {-# LANGUAGE OverloadedStrings #-} module Handler.Delete where import Foundation import Yesod.Core -import qualified Data.ByteString.Char8 as S8 -import qualified Data.ByteString.Lazy as L -import qualified Network.HTTP.Types as HttpTypes import qualified Data.Text as DataText import Data.Aeson import Data.Maybe (fromMaybe) @@ -20,52 +16,32 @@ import Utils.FileUtils import Logger import Models.RestApiStatus import System.Directory +import FileSystemServiceClient.FileSystemServiceClient +import Network.HTTP.Types +import Data.ByteString + + +serverPort = port 80 +deleteDeleteR :: Int -> Handler Value +deleteDeleteR inodeId = do + App{fileSystemServiceClient = FileSystemServiceClient{deleteInode= deleteInode}} <- getYesod + authToken <- lookupBearerAuth + case authToken of + Nothing -> notAuthenticated + Just bearerToken -> do + (responseBody, responseStatusCode, responseStatusMessage) <- liftIO $ deleteInode bearerToken (show inodeId) + case responseStatusCode of + 200 -> do + case fromJSON responseBody of + Success inodes -> do + liftIO $ mapM_ deleteFile (Prelude.filter filterFiles inodes) -- Todo: check if file exists + return responseBody + Error _ -> sendResponseStatus (Status 500 "Internal Server Error.") $ toJSON $ RestApiStatus "Internal Server Error" "500" + _ -> sendResponseStatus (Status responseStatusCode responseStatusMessage) responseBody -deleteDeleteR :: Int -> Handler () -deleteDeleteR _ = - sendWaiApplication delete -delete :: Application -delete req send = do - logStdOut "requesting delete" - let headers = requestHeaders req - restUrl <- getRestUrl - (responseBody, responseStatusCode, responseStatusMessage) <- deleteApi headers restUrl (DataText.unpack $ pathInfo req !! 2) - case responseStatusCode of - 200 -> do - let d = (eitherDecode $ L.fromStrict responseBody) :: (Either String [Inode]) - case d of - Left err -> - send $ - responseLBS - HttpTypes.status500 - [("Content-Type", "application/json; charset=utf-8")] - (encode $ RestApiStatus err "Internal Server Error") - Right fileObjects -> do - mapM_ deleteFile (filter filterFiles fileObjects) - send $ - responseLBS - HttpTypes.status200 - [("Content-Type", "application/json; charset=utf-8")] - (L.fromStrict responseBody) - _ -> - send $ - responseLBS - (HttpTypes.mkStatus responseStatusCode responseStatusMessage) - [("Content-Type", "application/json; charset=utf-8")] - (L.fromStrict responseBody) -deleteApi :: [HttpTypes.Header] -> String -> String -> IO (S8.ByteString, Int, S8.ByteString) -deleteApi allHeaders restUrl fileId = runReq (defaultHttpConfig {httpConfigCheckResponse = httpConfigDontCheckResponse}) $ do - r <- - req - 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 - return (responseBody r, responseStatusCode r, responseStatusMessage r) deleteFile :: Inode -> IO () deleteFile file = removeFile $ getPathFromFileId (show $ fileSystemId file) diff --git a/src/Handler/Health.hs b/src/Handler/Health.hs index 5d489cc..c0f3b01 100644 --- a/src/Handler/Health.hs +++ b/src/Handler/Health.hs @@ -1,41 +1,46 @@ +-- | {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} --- | module Handler.Health where -import Control.Monad -import Data.Aeson import Foundation +import Yesod.Core import qualified Network.HTTP.Types as HttpTypes import Network.Wai -import System.Directory +import Data.Aeson import System.Environment +import System.Directory import System.FilePath -import Yesod.Core +import Control.Monad +import GHC.Generics +import Settings (AppSettings(AppSettings), appProfile) + -data HealthInfo = HealthInfo - { version :: String, - deploymentType :: String, - actualFilesSize :: Integer, - fileCount :: Int +data HealthInfo =HealthInfo + { version :: String + , deploymentType :: String + , actualFilesSize :: Integer + , fileCount :: Int } + deriving (Show, Generic) + +instance ToJSON HealthInfo -getHealthR :: Handler HealthInfo +getHealthR :: Handler Value getHealthR = do - deploymentType <- liftIO getDeploymentType + App{appSettings = AppSettings {appProfile = deploymentType}} <- getYesod files <- liftIO $ concat <$> (mapM listDirectoryRelative =<< (filterM doesDirectoryExist =<< listDirectory ".")) actualFilesSize <- liftIO $ sum <$> mapM getFileSize files let response = HealthInfo - { version = "0.2.1" :: String, - deploymentType = deploymentType, - actualFilesSize = actualFilesSize, - fileCount = length files + { version = "0.2.1" :: String + , deploymentType = deploymentType + , actualFilesSize = actualFilesSize + , fileCount = length files } - return response + returnJson response -getDeploymentType :: IO String -getDeploymentType = head . tail <$> getArgs listDirectoryRelative :: FilePath -> IO [FilePath] listDirectoryRelative x = Prelude.map (x ) <$> listDirectory x diff --git a/src/Handler/Upload.hs b/src/Handler/Upload.hs index b7e515d..2937937 100644 --- a/src/Handler/Upload.hs +++ b/src/Handler/Upload.hs @@ -4,8 +4,6 @@ module Handler.Upload where -import Network.Wai -import Network.Wai.Parse import qualified Network.HTTP.Types as HttpTypes import qualified Data.ByteString.Char8 as S8 @@ -25,85 +23,119 @@ import Models.RestApiStatus import Logger import Foundation import Yesod.Core hiding (fileContentType) +import ClassyPrelude.Conduit (runConduit, (.|), sinkFile) +import FileSystemServiceClient.FileSystemServiceClient +import Data.ByteString.Char8 +import qualified Data.Text as Text +import ClassyPrelude.Yesod (FileInfo(fileContentType)) +import Yesod.Core.Handler (sendResponseCreated) -postUploadR :: Handler () -postUploadR = - sendWaiApplication upload - -upload :: Application -upload req send = runResourceT $ - withInternalState $ - \internalState -> - do - (_params, files) <- parseRequestBody (tempFileBackEnd internalState) req - let headers = requestHeaders req - -- debug (_params) - -- Look for the file parameter called "file" - case lookup "file" files of - -- Not found, so return a 400 response - Nothing -> - send $ - responseLBS - HttpTypes.status400 - [("Content-Type", "application/json; charset=utf-8")] - (encode $ RestApiStatus "No file parameter found" "Bad Request") - -- Got it! - Just file -> do - let content = fileContent file - restUrl <- getRestUrl - (responseBody, responseStatusCode, responseStatusMessage) <- postApi headers file restUrl (DataText.unpack $ pathInfo req !! 2) - case responseStatusCode of - 201 -> do - let d = (eitherDecode $ L.fromStrict responseBody) :: (Either String [Inode]) - case d of - Left err -> - send $ - responseLBS - HttpTypes.status500 - [("Content-Type", "application/json; charset=utf-8")] - (encode $ RestApiStatus err "Internal Server Error") - Right filesAndFolders -> - case filter filterFiles filesAndFolders of - [] -> - send $ - responseLBS - HttpTypes.status500 - [("Content-Type", "application/json; charset=utf-8")] - (encode $ RestApiStatus "No file found in rest response." "Internal Server Error") - [file] -> do - let id = show $ fileSystemId file - createDirectoryIfMissing True [head id] - copyFile content (getPathFromFileId id) - logStdOut ("Uploaded " ++ (head id : ("/" ++ id))) - send $ - responseLBS - HttpTypes.status200 - [("Content-Type", "application/json; charset=utf-8")] - (L.fromStrict responseBody) - _ -> - send $ - responseLBS - (HttpTypes.mkStatus responseStatusCode responseStatusMessage) - [("Content-Type", "application/json; charset=utf-8")] - (L.fromStrict responseBody) - -postApi :: [HttpTypes.Header] -> Network.Wai.Parse.FileInfo c -> String -> String -> IO (S8.ByteString, Int, S8.ByteString) -postApi allHeaders file restUrl fileId = runReq (defaultHttpConfig {httpConfigCheckResponse = httpConfigDontCheckResponse}) $ do - let payload = - object - [ "name" .= S8.unpack (getOneHeader allHeaders "X-FF-NAME"), -- name and path are taken from headers - "path" .= S8.unpack (getOneHeader allHeaders "X-FF-PATH"), -- because they could have been change by the user in the frontend - "mimeType" .= S8.unpack (fileContentType file), - "size" .= S8.unpack (getOneHeader allHeaders "X-FF-SIZE") - ] - - r <- - req - POST -- method - --(http (DataText.pack restUrl) /: "t/os3vu-1615111052/post") - (http (DataText.pack restUrl) /: "api" /: "v1" /: "filesystem" /: DataText.pack fileId /: "upload") - (ReqBodyJson payload) -- use built-in options or add your own - bsResponse -- specify how to interpret response - (header "Authorization" (getOneHeader allHeaders "Authorization") <> port 8080) - return (responseBody r, responseStatusCode r, responseStatusMessage r) +postUploadR :: Int -> Handler () +postUploadR parentId= do + App{fileSystemServiceClient = FileSystemServiceClient{createInode= createInode}} <- getYesod + authToken <- lookupBearerAuth + case authToken of + Nothing -> notAuthenticated + Just bearerToken -> do + (_params, files) <- runRequestBody + inodeToUpload <- lookupUploadedInode (Text.unpack . fileContentType <$> lookupSingleFile files ) + case inodeToUpload of + Nothing -> return () + Just inode -> do + (responseBody, responseStatusCode, responseStatusMessage) <- liftIO $ createInode bearerToken inode (show parentId) + return () + + +lookupUploadedInode ::MonadHandler m => Maybe String -> m (Maybe UploadedInode) +lookupUploadedInode mimeType = do + name <- lookupHeader $ Data.CaseInsensitive.mk "X-FF-NAME" + path <- lookupHeader $ Data.CaseInsensitive.mk "X-FF-PATH" + size <- lookupHeader $ Data.CaseInsensitive.mk "X-FF-SIZE" + + return $ UploadedInode <$> (unpack <$> name) <*> (unpack <$> path) <*> mimeType <*> (unpack <$> size) + + + + +lookupSingleFile :: [(Text.Text,FileInfo)] -> Maybe FileInfo +lookupSingleFile [(_,file)] = Just file +lookupSingleFile _ = Nothing + + +-- upload :: Application +-- upload req send = runResourceT $ +-- withInternalState $ +-- \internalState -> +-- do +-- (_params, files) <- parseRequestBody (tempFileBackEnd internalState) req +-- let headers = requestHeaders req +-- -- debug (_params) +-- -- Look for the file parameter called "file" +-- case lookup "file" files of +-- -- Not found, so return a 400 response +-- Nothing -> +-- send $ +-- responseLBS +-- HttpTypes.status400 +-- [("Content-Type", "application/json; charset=utf-8")] +-- (encode $ RestApiStatus "No file parameter found" "Bad Request") +-- -- Got it! +-- Just file -> do +-- let content = fileContent file +-- restUrl <- getRestUrl +-- (responseBody, responseStatusCode, responseStatusMessage) <- postApi headers file restUrl (DataText.unpack $ pathInfo req !! 2) +-- case responseStatusCode of +-- 201 -> do +-- let d = (eitherDecode $ L.fromStrict responseBody) :: (Either String [Inode]) +-- case d of +-- Left err -> +-- send $ +-- responseLBS +-- HttpTypes.status500 +-- [("Content-Type", "application/json; charset=utf-8")] +-- (encode $ RestApiStatus err "Internal Server Error") +-- Right filesAndFolders -> +-- case filter filterFiles filesAndFolders of +-- [] -> +-- send $ +-- responseLBS +-- HttpTypes.status500 +-- [("Content-Type", "application/json; charset=utf-8")] +-- (encode $ RestApiStatus "No file found in rest response." "Internal Server Error") +-- [file] -> do +-- let id = show $ fileSystemId file +-- createDirectoryIfMissing True [head id] +-- copyFile content (getPathFromFileId id) +-- logStdOut ("Uploaded " ++ (head id : ("/" ++ id))) +-- send $ +-- responseLBS +-- HttpTypes.status200 +-- [("Content-Type", "application/json; charset=utf-8")] +-- (L.fromStrict responseBody) +-- _ -> +-- send $ +-- responseLBS +-- (HttpTypes.mkStatus responseStatusCode responseStatusMessage) +-- [("Content-Type", "application/json; charset=utf-8")] +-- (L.fromStrict responseBody) + +-- postApi :: [HttpTypes.Header] -> Network.Wai.Parse.FileInfo c -> String -> String -> IO (S8.ByteString, Int, S8.ByteString) +-- postApi allHeaders file restUrl fileId = runReq (defaultHttpConfig {httpConfigCheckResponse = httpConfigDontCheckResponse}) $ do +-- let payload = +-- object +-- [ "name" .= S8.unpack (getOneHeader allHeaders "X-FF-NAME"), -- name and path are taken from headers +-- "path" .= S8.unpack (getOneHeader allHeaders "X-FF-PATH"), -- because they could have been change by the user in the frontend +-- "mimeType" .= S8.unpack (fileContentType file), +-- "size" .= S8.unpack (getOneHeader allHeaders "X-FF-SIZE") +-- ] + +-- r <- +-- req +-- POST -- method +-- --(http (DataText.pack restUrl) /: "t/os3vu-1615111052/post") +-- (http (DataText.pack restUrl) /: "api" /: "v1" /: "filesystem" /: DataText.pack fileId /: "upload") +-- (ReqBodyJson payload) -- use built-in options or add your own +-- bsResponse -- specify how to interpret response +-- (header "Authorization" (getOneHeader allHeaders "Authorization") <> port 8080) +-- return (responseBody r, responseStatusCode r, responseStatusMessage r) diff --git a/stack.yaml b/stack.yaml index 1b0ab22..5560d7d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -18,7 +18,8 @@ # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml resolver: - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/23.yaml + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/31.yaml + # User packages to be built. # Various formats can be used as shown in the example below. diff --git a/stack.yaml.lock b/stack.yaml.lock index 56a0f91..49011c7 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -6,8 +6,8 @@ packages: [] snapshots: - completed: - sha256: 7f69bb29a57495586e7e3ed31ecc59c0d2c959cb23bd52b71ca676f254c9beb1 - size: 587819 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/23.yaml + sha256: 637fb77049b25560622a224845b7acfe81a09fdb6a96a3c75997a10b651667f6 + size: 534126 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/31.yaml original: - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/23.yaml + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/31.yaml From bacd48f927775afb5ec1346ac6d0716a5f21f185 Mon Sep 17 00:00:00 2001 From: qvalentin Date: Thu, 3 Feb 2022 19:18:56 +0100 Subject: [PATCH 04/35] Upload Migrated, streaming working for preview --- config/settings.yml | 7 + src/FileStorage.hs | 26 +++ .../FileSystemServiceClient.hs | 83 ++++++++ src/Foundation.hs | 29 ++- src/Handler/Delete.hs | 3 +- src/Handler/Preview.hs | 150 +++++++------- src/Handler/Upload.hs | 191 +++++++----------- src/Settings.hs | 55 +++++ src/Utils/ResponeUtils.hs | 10 + 9 files changed, 355 insertions(+), 199 deletions(-) create mode 100644 config/settings.yml create mode 100644 src/FileStorage.hs create mode 100644 src/FileSystemServiceClient/FileSystemServiceClient.hs create mode 100644 src/Settings.hs create mode 100644 src/Utils/ResponeUtils.hs diff --git a/config/settings.yml b/config/settings.yml new file mode 100644 index 0000000..bad2be1 --- /dev/null +++ b/config/settings.yml @@ -0,0 +1,7 @@ + + +appProfile: "_env:APP_PROFILE:prod" + +fileSystemServiceSettings: + url: "_env:FILESYSTEMSERVICE_URL:localhost" + port: "_env:FILESYSTEMSERVICE_PORT:8080" diff --git a/src/FileStorage.hs b/src/FileStorage.hs new file mode 100644 index 0000000..7418f16 --- /dev/null +++ b/src/FileStorage.hs @@ -0,0 +1,26 @@ +-- | + +module FileStorage where +import Yesod +import Data.ByteString +import Models.Inode +import ClassyPrelude.Yesod +import System.Directory +import qualified Data.Conduit.Binary as CB + + + +storeFile :: MonadResource m => Inode -> IO (ConduitT ByteString o m ()) +storeFile inode = do + let id = show $ fileSystemId inode + createDirectoryIfMissing True [Prelude.head id] + return $sinkFile (getPathFromFileId id) + + +retrieveFile :: MonadResource m => Inode ->ConduitT i ByteString m () +retrieveFile inode= do + let id = show $ fileSystemId inode + CB.sourceFile (getPathFromFileId id) + +getPathFromFileId :: String -> String +getPathFromFileId id=Prelude.head id : ("/" Prelude.++id) diff --git a/src/FileSystemServiceClient/FileSystemServiceClient.hs b/src/FileSystemServiceClient/FileSystemServiceClient.hs new file mode 100644 index 0000000..8169ceb --- /dev/null +++ b/src/FileSystemServiceClient/FileSystemServiceClient.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +module FileSystemServiceClient.FileSystemServiceClient where + +import qualified Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import Data.Aeson +import Data.ByteString.Char8 (ByteString) +import Data.Text +import Data.Text.Encoding (encodeUtf8) +import GHC.Generics +import Network.HTTP.Req hiding (port) +import qualified Network.HTTP.Req as Req +import Settings +import Utils.RequestUtils + +data FileSystemServiceClient = FileSystemServiceClient + { deleteInode :: Text -> String -> IO (Value, Int, ByteString), + createInode :: Text -> UploadedInode -> String -> IO (Value, Int, ByteString), + getInodeInfo ::Text -> String -> IO (Value, Int, ByteString), + downloadInode :: () + } + +data UploadedInode = UploadedInode + { name :: String, + path :: String, + mimeType :: String, + size :: String + } + deriving (Show, Generic) + +instance ToJSON UploadedInode + +makeFileSystemServiceClient :: FileSystemServiceSettings -> FileSystemServiceClient +makeFileSystemServiceClient fileSystemServiceSettings = + FileSystemServiceClient + { deleteInode = makeDeleteInode fileSystemServiceSettings, + createInode = makeCreateInode fileSystemServiceSettings, + getInodeInfo = makeGetInodeInfo fileSystemServiceSettings, + downloadInode = () + } + +makeDeleteInode :: FileSystemServiceSettings -> Text -> String -> IO (Value, Int, ByteString) +makeDeleteInode r@FileSystemServiceSettings {url = url, port = port} authorization fileId = runReq (defaultHttpConfig {httpConfigCheckResponse = httpConfigDontCheckResponse}) $ do + r <- + req + DELETE + (http (pack url) /: "v1" /: "filesystem" /: pack fileId /: "delete") + NoReqBody + jsonResponse + (oAuth2Bearer' (encodeUtf8 authorization) <> Req.port port) -- parentID not in Headers + return (responseBody r, responseStatusCode r, responseStatusMessage r) + +oAuth2Bearer' token = header "Authorization" ("Bearer " <> token) + +makeCreateInode :: FileSystemServiceSettings -> Text -> UploadedInode -> String -> IO (Value, Int, ByteString) +makeCreateInode r@FileSystemServiceSettings {url = url, port = port} authorization uploadedInode fileId = runReq (defaultHttpConfig {httpConfigCheckResponse = httpConfigDontCheckResponse}) $ do + r <- + req + POST -- method + --(http (DataText.pack restUrl) /: "t/os3vu-1615111052/post") + (http (pack url) /: "v1" /: "filesystem" /: pack fileId /: "upload") + (ReqBodyJson uploadedInode) -- use built-in options or add your own + jsonResponse + (oAuth2Bearer' (encodeUtf8 authorization) <> Req.port port) -- parentID not in Headers + return (responseBody r, responseStatusCode r, responseStatusMessage r) + +makeGetInodeInfo :: FileSystemServiceSettings -> Text -> String -> IO (Value, Int, ByteString) +makeGetInodeInfo r@FileSystemServiceSettings {url = url, port = port} authorization id = runReq (defaultHttpConfig {httpConfigCheckResponse = httpConfigDontCheckResponse}) $ do + r <- + req + GET -- method + (http (pack url) /: "v1" /: "filesystem" /: pack id /: "info") -- safe by construction URL + --(http (DataText.pack restUrl) /: "v1" /: "filesystem" /: id /: "info" ) -- safe by construction URL + NoReqBody -- use built-in options or add your own + jsonResponse -- specify how to interpret response + (oAuth2Bearer' (encodeUtf8 authorization) <> Req.port port) + -- mempty -- query params, headers, explicit port number, etc. + return (responseBody r, responseStatusCode r, responseStatusMessage r) diff --git a/src/Foundation.hs b/src/Foundation.hs index ca43ebe..064b90e 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1,18 +1,33 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + module Foundation where -import Yesod.Core -import Settings (AppSettings) import FileSystemServiceClient.FileSystemServiceClient + ( FileSystemServiceClient, + ) +import Network.Wai.Parse + ( tempFileBackEnd, + ) +import Settings (AppSettings) +import Yesod.Core + ( FileUpload (FileUploadDisk), + RenderRoute (renderRoute), + Yesod (fileUpload, maximumContentLength), + mkYesodData, + parseRoutesFile, + ) data App = App - { appSettings :: AppSettings - , fileSystemServiceClient :: FileSystemServiceClient + { appSettings :: AppSettings, + fileSystemServiceClient :: FileSystemServiceClient } mkYesodData "App" $(parseRoutesFile "routes.yesodroutes") instance Yesod App where + maximumContentLength _ (Just (UploadR _)) = Nothing + maximumContentLength _ _ = Just (2 * 1024 * 1024) -- 2 megabytes + fileUpload _ _ = FileUploadDisk tempFileBackEnd diff --git a/src/Handler/Delete.hs b/src/Handler/Delete.hs index c83999d..05730f4 100644 --- a/src/Handler/Delete.hs +++ b/src/Handler/Delete.hs @@ -19,6 +19,7 @@ import System.Directory import FileSystemServiceClient.FileSystemServiceClient import Network.HTTP.Types import Data.ByteString +import Utils.ResponeUtils (sendInternalError) @@ -38,7 +39,7 @@ deleteDeleteR inodeId = do Success inodes -> do liftIO $ mapM_ deleteFile (Prelude.filter filterFiles inodes) -- Todo: check if file exists return responseBody - Error _ -> sendResponseStatus (Status 500 "Internal Server Error.") $ toJSON $ RestApiStatus "Internal Server Error" "500" + Error _ -> sendInternalError _ -> sendResponseStatus (Status responseStatusCode responseStatusMessage) responseBody diff --git a/src/Handler/Preview.hs b/src/Handler/Preview.hs index e8a14b7..567ea89 100644 --- a/src/Handler/Preview.hs +++ b/src/Handler/Preview.hs @@ -9,7 +9,7 @@ import Yesod.Core import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import qualified Network.HTTP.Types as HttpTypes -import qualified Data.Text as DataText +import qualified Data.Text import Data.Aeson import Data.Maybe (fromMaybe) @@ -23,71 +23,85 @@ import Logger import Network.HTTP.Req import Network.Wai import Utils.FileUtils +import FileSystemServiceClient.FileSystemServiceClient +import ClassyPrelude.Yesod +import FileStorage (retrieveFile) +import Utils.ResponeUtils (sendInternalError) +import qualified ClassyPrelude.Conduit as CB -getPreviewR :: Int -> Handler () -getPreviewR _ = - sendWaiApplication preview - -preview :: Application -preview req send = do - let headers = requestHeaders req - id = pathInfo req !! 2 - redirectOnError = True --todo: make this a query param or something - restUrl <- getRestUrl - (responseBody, responseStatusCode, responseStatusMessage) <- previewApi headers id restUrl - logStdOut $ S8.unpack responseStatusMessage - case (responseStatusCode, redirectOnError) of - (200, _) -> do - let decoded = (eitherDecode $ L.fromStrict responseBody) :: (Either String Inode) - case decoded of - Left err -> - send $ - responseLBS - HttpTypes.status500 - [("Content-Type", "application/json; charset=utf-8")] - (encode $ RestApiStatus err "Internal Server Error") - Right file -> - let fileID = fileSystemId file - fileMimeType = fromMaybe "application/octet-stream" (mimeType file) - path = getPathFromFileId $ show fileID - in send $ - responseFile - HttpTypes.status200 - [("Content-Type", S8.pack fileMimeType)] - path - Nothing - (_, True) -> do - let decoded = (eitherDecode $ L.fromStrict responseBody) :: (Either String RestApiStatus) - case decoded of - Left err -> - send $ - responseLBS - HttpTypes.status500 - [("Content-Type", "application/json; charset=utf-8")] - (encode $ RestApiStatus err "Internal Server Error") - Right status -> - let location = - "/error?dest=" <> HttpTypes.urlEncode True (rawPathInfo req) - <> "&message=" - <> HttpTypes.urlEncode True (S8.pack $ message status) - in send $ responseLBS HttpTypes.status303 [("Location", location)] "" - (_, False) -> - send $ - responseLBS - (HttpTypes.mkStatus responseStatusCode responseStatusMessage) - [("Content-Type", "application/json; charset=utf-8")] - (L.fromStrict responseBody) - -previewApi :: [HttpTypes.Header] -> DataText.Text -> String -> IO (S8.ByteString, Int, S8.ByteString) -previewApi allHeaders id restUrl = runReq (defaultHttpConfig {httpConfigCheckResponse = httpConfigDontCheckResponse}) $ do - r <- - req - GET -- method - (http (DataText.pack restUrl) /: "api" /: "v1" /: "filesystem" /: id /: "info") -- safe by construction URL - --(http (DataText.pack restUrl) /: "v1" /: "filesystem" /: id /: "info" ) -- safe by construction URL - NoReqBody -- use built-in options or add your own - bsResponse -- specify how to interpret response - (header "Cookie" (getOneHeader allHeaders "Cookie") <> port 8080) --PORT !! - -- mempty -- query params, headers, explicit port number, etc. - liftIO $ logStdOut "Requested fileinfo" - return (responseBody r, responseStatusCode r, responseStatusMessage r) +getPreviewR :: Int -> String -> Handler TypedContent +getPreviewR id _ = do + App{fileSystemServiceClient = FileSystemServiceClient{getInodeInfo=getInodeInfo}} <- getYesod + bearerToken <- lookupAuth + + (responseBody, responseStatusCode, responseStatusMessage) <- liftIO $ getInodeInfo bearerToken $ show id + case responseStatusCode of + 200 -> do + case fromJSON responseBody of + Success inode -> do + respondSource "text/plain" $ do + retrieveFile inode .| awaitForever sendChunkBS + + Error _ -> sendInternalError + _ -> sendResponseStatus (Status responseStatusCode responseStatusMessage) responseBody + + + + + + + +lookupAuth :: MonadHandler m => m Text +lookupAuth = do + authToken <- lookupCookie "token" + maybe notAuthenticated return authToken + +-- preview :: Application +-- preview req send = do +-- let headers = requestHeaders req +-- id = pathInfo req !! 2 +-- redirectOnError = True --todo: make this a query param or something +-- restUrl <- getRestUrl +-- (responseBody, responseStatusCode, responseStatusMessage) <- previewApi headers id restUrl +-- logStdOut $ S8.unpack responseStatusMessage +-- case (responseStatusCode, redirectOnError) of +-- (200, _) -> do +-- let decoded = (eitherDecode $ L.fromStrict responseBody) :: (Either String Inode) +-- case decoded of +-- Left err -> +-- send $ +-- responseLBS +-- HttpTypes.status500 +-- [("Content-Type", "application/json; charset=utf-8")] +-- (encode $ RestApiStatus err "Internal Server Error") +-- Right file -> +-- let fileID = fileSystemId file +-- fileMimeType = fromMaybe "application/octet-stream" (mimeType file) +-- path = getPathFromFileId $ show fileID +-- in send $ +-- responseFile +-- HttpTypes.status200 +-- [("Content-Type", S8.pack fileMimeType)] +-- path +-- Nothing +-- (_, True) -> do +-- let decoded = (eitherDecode $ L.fromStrict responseBody) :: (Either String RestApiStatus) +-- case decoded of +-- Left err -> +-- send $ +-- responseLBS +-- HttpTypes.status500 +-- [("Content-Type", "application/json; charset=utf-8")] +-- (encode $ RestApiStatus err "Internal Server Error") +-- Right status -> +-- let location = +-- "/error?dest=" <> HttpTypes.urlEncode True (rawPathInfo req) +-- <> "&message=" +-- <> HttpTypes.urlEncode True (S8.pack $ message status) +-- in send $ responseLBS HttpTypes.status303 [("Location", location)] "" +-- (_, False) -> +-- send $ +-- responseLBS +-- (HttpTypes.mkStatus responseStatusCode responseStatusMessage) +-- [("Content-Type", "application/json; charset=utf-8")] +-- (L.fromStrict responseBody) diff --git a/src/Handler/Upload.hs b/src/Handler/Upload.hs index 2937937..84e6ee9 100644 --- a/src/Handler/Upload.hs +++ b/src/Handler/Upload.hs @@ -1,141 +1,86 @@ --- | {-# LANGUAGE OverloadedStrings #-} +-- | module Handler.Upload where - - -import qualified Network.HTTP.Types as HttpTypes -import qualified Data.ByteString.Char8 as S8 -import qualified Data.ByteString.Lazy as L -import qualified Data.Text as DataText -import Control.Monad.State -import Control.Monad.Trans.Resource -import Network.HTTP.Req -import Data.CaseInsensitive -import System.Directory - -import Models.Inode -import Utils.RequestUtils -import Utils.FileUtils +import ClassyPrelude.Conduit (runConduit, sinkFile, (.|)) +import ClassyPrelude.Yesod + ( FileInfo (fileContentType), + runConduitRes, + (.|), + ) import Data.Aeson -import Models.RestApiStatus -import Logger -import Foundation -import Yesod.Core hiding (fileContentType) -import ClassyPrelude.Conduit (runConduit, (.|), sinkFile) + ( Result (Error, Success), + Value, + fromJSON, + object, + ) +import qualified Data.ByteString.Char8 as S8 +import Data.CaseInsensitive (mk) +import qualified Data.Text as Text +import FileStorage (storeFile) import FileSystemServiceClient.FileSystemServiceClient -import Data.ByteString.Char8 -import qualified Data.Text as Text -import ClassyPrelude.Yesod (FileInfo(fileContentType)) + ( FileSystemServiceClient (FileSystemServiceClient, createInode), + UploadedInode (UploadedInode), + ) +import Foundation (App (App, fileSystemServiceClient), Handler) +import Models.Inode (Inode (fileSystemId)) +import Network.HTTP.Types (Status (Status)) +import Utils.FileUtils (filterFiles) +import Utils.ResponeUtils (sendInternalError) +import Yesod.Core + ( FileInfo, + MonadHandler, + MonadIO (liftIO), + fileSource, + getYesod, + invalidArgs, + lookupBearerAuth, + lookupHeader, + notAuthenticated, + runRequestBody, + sendResponseStatus, + ) import Yesod.Core.Handler (sendResponseCreated) -postUploadR :: Int -> Handler () -postUploadR parentId= do - App{fileSystemServiceClient = FileSystemServiceClient{createInode= createInode}} <- getYesod - authToken <- lookupBearerAuth +postUploadR :: Int -> Handler Value +postUploadR parentId = do + App {fileSystemServiceClient = FileSystemServiceClient {createInode = createInode}} <- getYesod + authToken <- lookupBearerAuth case authToken of Nothing -> notAuthenticated Just bearerToken -> do - (_params, files) <- runRequestBody - inodeToUpload <- lookupUploadedInode (Text.unpack . fileContentType <$> lookupSingleFile files ) - case inodeToUpload of - Nothing -> return () - Just inode -> do - (responseBody, responseStatusCode, responseStatusMessage) <- liftIO $ createInode bearerToken inode (show parentId) - return () - - - -lookupUploadedInode ::MonadHandler m => Maybe String -> m (Maybe UploadedInode) + (_params, files) <- runRequestBody + case lookupSingleFile files of + Nothing -> invalidArgs ["Missing required File."] + Just file -> do + inodeToCreate <- lookupUploadedInode $ Just (Text.unpack $ fileContentType file) + case inodeToCreate of + Nothing -> invalidArgs ["Missing required Header."] + Just inode -> do + (responseBody, responseStatusCode, responseStatusMessage) <- liftIO $ createInode bearerToken inode (show parentId) + case responseStatusCode of + 201 -> do + case fromJSON responseBody of + Success createdInodes -> do + case Prelude.filter filterFiles createdInodes of + [singleInode] -> do + let a = fileSystemId singleInode + fileDest <- liftIO $ storeFile singleInode + runConduitRes $ fileSource file .| fileDest + return responseBody + _ -> sendInternalError + Error _ -> sendInternalError + _ -> sendResponseStatus (Status responseStatusCode responseStatusMessage) responseBody + +lookupUploadedInode :: MonadHandler m => Maybe String -> m (Maybe UploadedInode) lookupUploadedInode mimeType = do name <- lookupHeader $ Data.CaseInsensitive.mk "X-FF-NAME" path <- lookupHeader $ Data.CaseInsensitive.mk "X-FF-PATH" size <- lookupHeader $ Data.CaseInsensitive.mk "X-FF-SIZE" - return $ UploadedInode <$> (unpack <$> name) <*> (unpack <$> path) <*> mimeType <*> (unpack <$> size) - - - + return $ UploadedInode <$> (S8.unpack <$> name) <*> (S8.unpack <$> path) <*> mimeType <*> (S8.unpack <$> size) -lookupSingleFile :: [(Text.Text,FileInfo)] -> Maybe FileInfo -lookupSingleFile [(_,file)] = Just file +lookupSingleFile :: [(Text.Text, FileInfo)] -> Maybe FileInfo +lookupSingleFile [("file", file)] = Just file lookupSingleFile _ = Nothing - - --- upload :: Application --- upload req send = runResourceT $ --- withInternalState $ --- \internalState -> --- do --- (_params, files) <- parseRequestBody (tempFileBackEnd internalState) req --- let headers = requestHeaders req --- -- debug (_params) --- -- Look for the file parameter called "file" --- case lookup "file" files of --- -- Not found, so return a 400 response --- Nothing -> --- send $ --- responseLBS --- HttpTypes.status400 --- [("Content-Type", "application/json; charset=utf-8")] --- (encode $ RestApiStatus "No file parameter found" "Bad Request") --- -- Got it! --- Just file -> do --- let content = fileContent file --- restUrl <- getRestUrl --- (responseBody, responseStatusCode, responseStatusMessage) <- postApi headers file restUrl (DataText.unpack $ pathInfo req !! 2) --- case responseStatusCode of --- 201 -> do --- let d = (eitherDecode $ L.fromStrict responseBody) :: (Either String [Inode]) --- case d of --- Left err -> --- send $ --- responseLBS --- HttpTypes.status500 --- [("Content-Type", "application/json; charset=utf-8")] --- (encode $ RestApiStatus err "Internal Server Error") --- Right filesAndFolders -> --- case filter filterFiles filesAndFolders of --- [] -> --- send $ --- responseLBS --- HttpTypes.status500 --- [("Content-Type", "application/json; charset=utf-8")] --- (encode $ RestApiStatus "No file found in rest response." "Internal Server Error") --- [file] -> do --- let id = show $ fileSystemId file --- createDirectoryIfMissing True [head id] --- copyFile content (getPathFromFileId id) --- logStdOut ("Uploaded " ++ (head id : ("/" ++ id))) --- send $ --- responseLBS --- HttpTypes.status200 --- [("Content-Type", "application/json; charset=utf-8")] --- (L.fromStrict responseBody) --- _ -> --- send $ --- responseLBS --- (HttpTypes.mkStatus responseStatusCode responseStatusMessage) --- [("Content-Type", "application/json; charset=utf-8")] --- (L.fromStrict responseBody) - --- postApi :: [HttpTypes.Header] -> Network.Wai.Parse.FileInfo c -> String -> String -> IO (S8.ByteString, Int, S8.ByteString) --- postApi allHeaders file restUrl fileId = runReq (defaultHttpConfig {httpConfigCheckResponse = httpConfigDontCheckResponse}) $ do --- let payload = --- object --- [ "name" .= S8.unpack (getOneHeader allHeaders "X-FF-NAME"), -- name and path are taken from headers --- "path" .= S8.unpack (getOneHeader allHeaders "X-FF-PATH"), -- because they could have been change by the user in the frontend --- "mimeType" .= S8.unpack (fileContentType file), --- "size" .= S8.unpack (getOneHeader allHeaders "X-FF-SIZE") --- ] - --- r <- --- req --- POST -- method --- --(http (DataText.pack restUrl) /: "t/os3vu-1615111052/post") --- (http (DataText.pack restUrl) /: "api" /: "v1" /: "filesystem" /: DataText.pack fileId /: "upload") --- (ReqBodyJson payload) -- use built-in options or add your own --- bsResponse -- specify how to interpret response --- (header "Authorization" (getOneHeader allHeaders "Authorization") <> port 8080) --- return (responseBody r, responseStatusCode r, responseStatusMessage r) diff --git a/src/Settings.hs b/src/Settings.hs new file mode 100644 index 0000000..f53a798 --- /dev/null +++ b/src/Settings.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | +module Settings where + +import ClassyPrelude.Yesod +import qualified Control.Exception as Exception +import Data.Aeson + ( Result (..), + fromJSON, + withObject, + (.!=), + (.:?), + ) +import Data.FileEmbed (embedFile) +import Data.Yaml (decodeEither') +import GHC.Generics +import Network.Wai.Handler.Warp (HostPreference) +import Yesod.Default.Config2 (applyEnvValue, configSettingsYml) +import Yesod.Default.Util + ( WidgetFileSettings, + widgetFileNoReload, + widgetFileReload, + ) + +data AppSettings = AppSettings + { appProfile :: String, + fileSystemServiceSettings :: FileSystemServiceSettings + } + deriving (Generic) + +instance FromJSON AppSettings + +data FileSystemServiceSettings = FileSystemServiceSettings + { url :: String, + port :: Int + } + deriving (Generic) + +instance FromJSON FileSystemServiceSettings + +-- | Raw bytes at compile time of @config/settings.yml@ +configSettingsYmlBS :: ByteString +configSettingsYmlBS = $(embedFile configSettingsYml) + +-- | @config/settings.yml@, parsed to a @Value@. +configSettingsYmlValue :: Value +configSettingsYmlValue = + either Exception.throw id $ + decodeEither' configSettingsYmlBS diff --git a/src/Utils/ResponeUtils.hs b/src/Utils/ResponeUtils.hs new file mode 100644 index 0000000..3e68438 --- /dev/null +++ b/src/Utils/ResponeUtils.hs @@ -0,0 +1,10 @@ +-- | +{-# LANGUAGE OverloadedStrings #-} + +module Utils.ResponeUtils where +import Yesod +import Network.HTTP.Types +import Models.RestApiStatus + +sendInternalError :: MonadHandler m => m a +sendInternalError =sendResponseStatus (Status 500 "Internal Server Error.") $ toJSON $ RestApiStatus "Internal Server Error" "500" From 0a170fc74f32d6a0c2d641928086df082ebb6f94 Mon Sep 17 00:00:00 2001 From: qvalentin Date: Sat, 5 Feb 2022 14:30:58 +0100 Subject: [PATCH 05/35] Refactoring finished --- package.yaml | 2 + routes.yesodroutes | 3 +- src/Application.hs | 2 +- src/FileStorage.hs | 9 +- .../FileSystemServiceClient.hs | 26 +- src/Foundation.hs | 1 + src/Handler/Delete.hs | 3 +- src/Handler/Download.hs | 298 ++++++++++-------- src/Handler/Error.hs | 7 + src/Handler/Preview.hs | 109 +------ src/Handler/Upload.hs | 2 +- src/Models/Inode.hs | 3 +- src/Utils/FileUtils.sh | 1 - src/Utils/HandlerUtils.hs | 49 +++ src/Utils/RequestUtils.hs | 20 -- src/Utils/ResponeUtils.hs | 10 - 16 files changed, 271 insertions(+), 274 deletions(-) create mode 100644 src/Handler/Error.hs delete mode 100644 src/Utils/FileUtils.sh create mode 100644 src/Utils/HandlerUtils.hs delete mode 100644 src/Utils/RequestUtils.hs delete mode 100644 src/Utils/ResponeUtils.hs diff --git a/package.yaml b/package.yaml index aa85925..b1683cd 100644 --- a/package.yaml +++ b/package.yaml @@ -25,6 +25,8 @@ dependencies: - filepath - yaml - file-embed +- zip-stream +- time diff --git a/routes.yesodroutes b/routes.yesodroutes index 1929826..77d3f68 100644 --- a/routes.yesodroutes +++ b/routes.yesodroutes @@ -2,5 +2,6 @@ /data/download DownloadR GET /data/upload/#Int UploadR POST /data/delete/#Int DeleteR DELETE -/data/preview/#Int PreviewR GET +/data/preview/#Int/#String PreviewR GET /data/health HealthR GET +/error ErrorR GET diff --git a/src/Application.hs b/src/Application.hs index d3c093d..9d7f8ab 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -1,7 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} module Application where @@ -14,6 +13,7 @@ import Handler.Health import Handler.Home import Handler.Preview import Handler.Upload +import Handler.Error import Settings import Yesod.Core diff --git a/src/FileStorage.hs b/src/FileStorage.hs index 7418f16..d4125fb 100644 --- a/src/FileStorage.hs +++ b/src/FileStorage.hs @@ -6,7 +6,7 @@ import Data.ByteString import Models.Inode import ClassyPrelude.Yesod import System.Directory -import qualified Data.Conduit.Binary as CB +import Data.Time @@ -20,7 +20,12 @@ storeFile inode = do retrieveFile :: MonadResource m => Inode ->ConduitT i ByteString m () retrieveFile inode= do let id = show $ fileSystemId inode - CB.sourceFile (getPathFromFileId id) + sourceFile (getPathFromFileId id) getPathFromFileId :: String -> String getPathFromFileId id=Prelude.head id : ("/" Prelude.++id) + +getInodeModifcationTime :: Inode -> IO UTCTime +getInodeModifcationTime inode = do + let id = show $ fileSystemId inode + getModificationTime (getPathFromFileId id) diff --git a/src/FileSystemServiceClient/FileSystemServiceClient.hs b/src/FileSystemServiceClient/FileSystemServiceClient.hs index 8169ceb..50b9d83 100644 --- a/src/FileSystemServiceClient/FileSystemServiceClient.hs +++ b/src/FileSystemServiceClient/FileSystemServiceClient.hs @@ -16,13 +16,13 @@ import GHC.Generics import Network.HTTP.Req hiding (port) import qualified Network.HTTP.Req as Req import Settings -import Utils.RequestUtils +import ClassyPrelude hiding (pack, encodeUtf8) data FileSystemServiceClient = FileSystemServiceClient { deleteInode :: Text -> String -> IO (Value, Int, ByteString), createInode :: Text -> UploadedInode -> String -> IO (Value, Int, ByteString), getInodeInfo ::Text -> String -> IO (Value, Int, ByteString), - downloadInode :: () + getInodeContent :: Text -> String -> IO (Value, Int, ByteString, Maybe ByteString) } data UploadedInode = UploadedInode @@ -35,13 +35,16 @@ data UploadedInode = UploadedInode instance ToJSON UploadedInode +httpConfigDontCheckResponse :: p1 -> p2 -> p3 -> Maybe a +httpConfigDontCheckResponse _ _ _ = Nothing + makeFileSystemServiceClient :: FileSystemServiceSettings -> FileSystemServiceClient makeFileSystemServiceClient fileSystemServiceSettings = FileSystemServiceClient { deleteInode = makeDeleteInode fileSystemServiceSettings, createInode = makeCreateInode fileSystemServiceSettings, getInodeInfo = makeGetInodeInfo fileSystemServiceSettings, - downloadInode = () + getInodeContent = makeGetInodeContent fileSystemServiceSettings } makeDeleteInode :: FileSystemServiceSettings -> Text -> String -> IO (Value, Int, ByteString) @@ -81,3 +84,20 @@ makeGetInodeInfo r@FileSystemServiceSettings {url = url, port = port} authorizat (oAuth2Bearer' (encodeUtf8 authorization) <> Req.port port) -- mempty -- query params, headers, explicit port number, etc. return (responseBody r, responseStatusCode r, responseStatusMessage r) + +makeGetInodeContent :: FileSystemServiceSettings -> Text -> String -> IO (Value, Int, ByteString, Maybe ByteString) +makeGetInodeContent r@FileSystemServiceSettings {url = url, port = port} authorization ids = runReq (defaultHttpConfig {httpConfigCheckResponse = httpConfigDontCheckResponse}) $ do + r <- + req + GET -- method + (http (pack url) /: "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 + jsonResponse -- specify how to interpret response + (oAuth2Bearer' (encodeUtf8 authorization) + <> Req.port port + <> header "X-FF-IDS" (fromString ids) + <> header "Cookie" ("token=" <> encodeUtf8 authorization) + <> (=:) "ids" ids ) + -- mempty -- query params, headers, explicit port number, etc. + return (responseBody r, responseStatusCode r, responseStatusMessage r, responseHeader r "X-FF-NAME") diff --git a/src/Foundation.hs b/src/Foundation.hs index 064b90e..da7a31f 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -19,6 +19,7 @@ import Yesod.Core mkYesodData, parseRoutesFile, ) +import Network.HTTP.Req data App = App { appSettings :: AppSettings, diff --git a/src/Handler/Delete.hs b/src/Handler/Delete.hs index 05730f4..9c47d45 100644 --- a/src/Handler/Delete.hs +++ b/src/Handler/Delete.hs @@ -10,7 +10,6 @@ import Data.Aeson import Data.Maybe (fromMaybe) import Models.Inode import Network.HTTP.Req -import Utils.RequestUtils import Network.Wai import Utils.FileUtils import Logger @@ -19,7 +18,7 @@ import System.Directory import FileSystemServiceClient.FileSystemServiceClient import Network.HTTP.Types import Data.ByteString -import Utils.ResponeUtils (sendInternalError) +import Utils.HandlerUtils diff --git a/src/Handler/Download.hs b/src/Handler/Download.hs index 67ec11b..6d5689e 100644 --- a/src/Handler/Download.hs +++ b/src/Handler/Download.hs @@ -1,142 +1,170 @@ - {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -module Handler.Download where - -import Foundation -import Yesod.Core +{-# LANGUAGE NoImplicitPrelude #-} +module Handler.Download where -import Network.Wai -import Codec.Archive.Zip - -import qualified Network.HTTP.Types as HttpTypes +import ClassyPrelude + ( Bool (True), + Either (Right), + FilePath, + IO, + Int, + IsString (fromString), + Maybe (..), + Monad (return), + MonadIO (..), + Show (show), + String, + UTCTime, + Utf8 (decodeUtf8), + defaultTimeLocale, + fromMaybe, + maybe, + pack, + parseTimeM, + unpack, + void, + ($), + (++), + (<$>), + ) +import ClassyPrelude.Yesod + ( ConduitM, + MonadHandler, + MonadResource, + TypedContent, + addHeader, + awaitForever, + getYesod, + invalidArgs, + lookupGetParam, + respondSource, + runConduitRes, + sendChunkBS, + sendFile, + sinkFile, + yield, + (.|), + ) +import Codec.Archive.Zip.Conduit.Zip + ( ZipData (ZipDataSource), + ZipEntry (..), + ZipInfo (ZipInfo, zipComment), + ZipOptions (..), + zipStream, + ) +import Data.Aeson () import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L +import Data.CaseInsensitive () +import Data.Maybe () import qualified Data.Text as DataText -import Data.Maybe -import Data.CaseInsensitive - -import Network.HTTP.Req -import System.Environment -import System.IO.Temp - - - - +import Data.Time (TimeZone, getCurrentTimeZone, utcToLocalTime) +import FileStorage (getInodeModifcationTime, retrieveFile) +import FileSystemServiceClient.FileSystemServiceClient + ( FileSystemServiceClient + ( FileSystemServiceClient, + getInodeContent + ), + ) +import Foundation (App (App, fileSystemServiceClient), Handler) +import Logger () import Models.Inode -import Models.RestApiStatus - -import Utils.RequestUtils -import Utils.FileUtils - -import Logger -import Data.Aeson - -getDownloadR :: Handler () -getDownloadR = - sendWaiApplication download - -download :: Application -download req send = do - let headers = requestHeaders req - queryParam = getDownloadQuery $ queryString req - redirectOnError = True --todo: make this a query param or something - case queryParam of - Nothing -> - send $ - responseLBS - HttpTypes.status501 - [("Content-Type", "application/json; charset=utf-8")] - "No ids parameter supplied." - Just param -> do - restUrl <- getRestUrl - logStdOut "download" - (responseBody, responseStatusCode, responseStatusMessage, fileNameHeader) <- getApi headers param restUrl - case (responseStatusCode, redirectOnError) of - (200, _) -> do - let d = (eitherDecode $ L.fromStrict responseBody) :: (Either String [Inode]) - 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 - files -> - withSystemTempFile "FileFighterFileHandler.zip" $ - \tmpFileName handle -> - do - let nameOfTheFolder = fromMaybe "Files" fileNameHeader - let ss = - mapM - ( \file -> do - inZipPath <- mkEntrySelector $ fromMaybe (name file) (path file) -- either take the filename or path - loadEntry Deflate inZipPath (getPathFromFileId (show $ fileSystemId file)) - ) - files - createArchive tmpFileName ss - send $ - responseFile - HttpTypes.status200 - [ ("Content-Disposition", S8.pack ("attachment; filename=\"" ++ S8.unpack nameOfTheFolder ++ ".zip" ++ "\"")), - ("Content-Type", "application/zip") - ] - tmpFileName - Nothing - (_, True) -> do - let decoded = (eitherDecode $ L.fromStrict responseBody) :: (Either String RestApiStatus) - case decoded of - Left err -> - send $ - responseLBS - HttpTypes.status500 - [("Content-Type", "application/json; charset=utf-8")] - (encode $ RestApiStatus err "Internal Server Error") - Right status -> - let location = - "/error?dest=" - <> HttpTypes.urlEncode True (rawPathInfo req) - <> HttpTypes.urlEncode True (rawQueryString req) - <> "&message=" - <> HttpTypes.urlEncode True (S8.pack $ message status) - in send $ responseLBS HttpTypes.status303 [("Location", location)] "" - (_, False) -> - send $ - responseLBS - (HttpTypes.mkStatus responseStatusCode responseStatusMessage) - [("Content-Type", "application/json; charset=utf-8")] - (L.fromStrict responseBody) - -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) /: "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 "Cookie" (getOneHeader allHeaders "Cookie") <> port 8080 <> (=:) "ids" param) --PORT !! - -- mempty -- query params, headers, explicit port number, etc. - liftIO $ logStdOut $ show (getOneHeader allHeaders "Cookie") - return (responseBody r, responseStatusCode r, responseStatusMessage r, responseHeader r "X-FF-NAME") - -getDownloadQuery :: HttpTypes.Query -> Maybe String -getDownloadQuery [(param, Just value)] = if param == "ids" then Just (S8.unpack value) else Nothing -getDownloadQuery _ = Nothing + ( Inode(lastUpdated, mimeType, name, size,path) ) +import Models.RestApiStatus () +import Network.HTTP.Req () +import qualified Network.HTTP.Types as HttpTypes +import Network.Wai () +import System.Directory (doesDirectoryExist, removeFile) +import System.Environment () +import System.IO () +import System.IO.Temp (emptySystemTempFile) +import UnliftIO.Resource (allocate) +import Utils.FileUtils () +import Utils.HandlerUtils (handleApiCall, lookupAuth) +import Yesod.Core () + +getDownloadR :: Handler ClassyPrelude.Yesod.TypedContent +getDownloadR = do + App {fileSystemServiceClient = FileSystemServiceClient {getInodeContent = getInodeContent}} <- ClassyPrelude.Yesod.getYesod + bearerToken <- lookupAuth + + inodeIds <- lookupRequiredInodeIds + (responseBody, responseStatusCode, responseStatusMessage, maybeFilename) <- liftIO $ getInodeContent bearerToken inodeIds + inodes <- handleApiCall responseBody responseStatusCode responseStatusMessage + case inodes of + [singleInode] -> do + ClassyPrelude.Yesod.addHeader "Content-Disposition" $ pack ("attachment; filename=\"" ++ Models.Inode.name singleInode ++ "\"") + ClassyPrelude.Yesod.respondSource (S8.pack $ fromMaybe "application/octet-stream" (Models.Inode.mimeType singleInode)) $ + retrieveFile singleInode ClassyPrelude.Yesod..| ClassyPrelude.Yesod.awaitForever ClassyPrelude.Yesod.sendChunkBS + multipleInodes -> do + let archiveName = fromMaybe "Files" maybeFilename + ClassyPrelude.Yesod.addHeader "Content-Disposition" ("attachment; filename=\"" ++ decodeUtf8 archiveName ++ ".zip" ++ "\"") + (_, tempFile) <- allocate (makeAllocateResource multipleInodes) freeResource + ClassyPrelude.Yesod.sendFile "application/zip" tempFile + +makeAllocateResource :: [Models.Inode.Inode] -> IO FilePath +makeAllocateResource inodes = do + path <- emptySystemTempFile "FileFighterFileHandler.zip" + createZip inodes path + return path + +freeResource :: FilePath -> IO () +freeResource = removeFile + +createZip :: [Models.Inode.Inode] -> FilePath -> IO () +createZip inodes filename = do + timeZone <- liftIO getCurrentTimeZone + ClassyPrelude.Yesod.runConduitRes $ + generateZipEntries inodes timeZone + ClassyPrelude.Yesod..| void (zipStream zipOptions) + ClassyPrelude.Yesod..| ClassyPrelude.Yesod.sinkFile filename + +generateZipEntries :: (MonadIO m, ClassyPrelude.Yesod.MonadResource m) => [Models.Inode.Inode] -> TimeZone -> ClassyPrelude.Yesod.ConduitM () (ZipEntry, ZipData m) m () +generateZipEntries (currentInode : nextInodes) timeZone = do + let nameInZip = fromMaybe (Models.Inode.name currentInode) $ Models.Inode.path currentInode + let size' = Models.Inode.size currentInode + timeStamp <- liftIO $ getTimestampForInode currentInode + let entry = + ZipEntry + { zipEntryName = Right $ fromString nameInZip, + zipEntryTime = utcToLocalTime timeZone timeStamp, + zipEntrySize = Nothing, -- Just (fromIntegral size'), + zipEntryExternalAttributes = Nothing + } + + ClassyPrelude.Yesod.yield (entry, ZipDataSource $retrieveFile currentInode) + generateZipEntries nextInodes timeZone + return () +generateZipEntries [] _ = return () + +zipOptions :: ZipOptions +zipOptions = + ZipOptions + { zipOpt64 = True, + zipOptCompressLevel = 9, + zipOptInfo = + ZipInfo + { zipComment = "" + } + } + +getTimestampForInode :: Models.Inode.Inode -> IO UTCTime +getTimestampForInode inode = do + let maybeTimeStamp = convertUnixTimeStamp (Models.Inode.lastUpdated inode) + case maybeTimeStamp of + Just timeStamp -> return timeStamp + Nothing -> getInodeModifcationTime inode + +convertUnixTimeStamp :: Int -> Maybe UTCTime +convertUnixTimeStamp ts = do + let i = parseTimeM True defaultTimeLocale "%s" (show ts) :: Maybe UTCTime + case i of + Just timeWithoutTimezone -> do + Just timeWithoutTimezone + Nothing -> Nothing + +lookupRequiredInodeIds :: ClassyPrelude.Yesod.MonadHandler m => m String +lookupRequiredInodeIds = do + maybeIds <- ClassyPrelude.Yesod.lookupGetParam "ids" + maybe (ClassyPrelude.Yesod.invalidArgs ["Missing ids query parameter."]) return $ unpack <$> maybeIds diff --git a/src/Handler/Error.hs b/src/Handler/Error.hs new file mode 100644 index 0000000..d799d9c --- /dev/null +++ b/src/Handler/Error.hs @@ -0,0 +1,7 @@ +-- | + +module Handler.Error where +import Foundation + +getErrorR :: Handler () +getErrorR = return () diff --git a/src/Handler/Preview.hs b/src/Handler/Preview.hs index 567ea89..8d6792c 100644 --- a/src/Handler/Preview.hs +++ b/src/Handler/Preview.hs @@ -1,107 +1,24 @@ --- | -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} module Handler.Preview where -import Foundation -import Yesod.Core - +import ClassyPrelude.Yesod import qualified Data.ByteString.Char8 as S8 -import qualified Data.ByteString.Lazy as L -import qualified Network.HTTP.Types as HttpTypes -import qualified Data.Text -import Data.Aeson -import Data.Maybe (fromMaybe) - +import FileStorage (retrieveFile) +import Foundation +import Models.Inode - -import Models.Inode -import Models.RestApiStatus -import Utils.RequestUtils -import Logger -import Network.HTTP.Req -import Network.Wai -import Utils.FileUtils -import FileSystemServiceClient.FileSystemServiceClient -import ClassyPrelude.Yesod -import FileStorage (retrieveFile) -import Utils.ResponeUtils (sendInternalError) -import qualified ClassyPrelude.Conduit as CB +import Utils.HandlerUtils +import FileSystemServiceClient.FileSystemServiceClient hiding (mimeType) getPreviewR :: Int -> String -> Handler TypedContent -getPreviewR id _ = do - App{fileSystemServiceClient = FileSystemServiceClient{getInodeInfo=getInodeInfo}} <- getYesod +getPreviewR inodeId _ = do + App {fileSystemServiceClient = FileSystemServiceClient {getInodeInfo = getInodeInfo'}} <- getYesod bearerToken <- lookupAuth - (responseBody, responseStatusCode, responseStatusMessage) <- liftIO $ getInodeInfo bearerToken $ show id - case responseStatusCode of - 200 -> do - case fromJSON responseBody of - Success inode -> do - respondSource "text/plain" $ do - retrieveFile inode .| awaitForever sendChunkBS - - Error _ -> sendInternalError - _ -> sendResponseStatus (Status responseStatusCode responseStatusMessage) responseBody - - - - - - - -lookupAuth :: MonadHandler m => m Text -lookupAuth = do - authToken <- lookupCookie "token" - maybe notAuthenticated return authToken + (responseBody', responseStatusCode, responseStatusMessage) <- liftIO $ getInodeInfo' bearerToken $ show inodeId + inode <- handleApiCall responseBody' responseStatusCode responseStatusMessage + respondSource (S8.pack $ fromMaybe "application/octet-stream" (mimeType inode)) $ + retrieveFile inode .| awaitForever sendChunkBS --- preview :: Application --- preview req send = do --- let headers = requestHeaders req --- id = pathInfo req !! 2 --- redirectOnError = True --todo: make this a query param or something --- restUrl <- getRestUrl --- (responseBody, responseStatusCode, responseStatusMessage) <- previewApi headers id restUrl --- logStdOut $ S8.unpack responseStatusMessage --- case (responseStatusCode, redirectOnError) of --- (200, _) -> do --- let decoded = (eitherDecode $ L.fromStrict responseBody) :: (Either String Inode) --- case decoded of --- Left err -> --- send $ --- responseLBS --- HttpTypes.status500 --- [("Content-Type", "application/json; charset=utf-8")] --- (encode $ RestApiStatus err "Internal Server Error") --- Right file -> --- let fileID = fileSystemId file --- fileMimeType = fromMaybe "application/octet-stream" (mimeType file) --- path = getPathFromFileId $ show fileID --- in send $ --- responseFile --- HttpTypes.status200 --- [("Content-Type", S8.pack fileMimeType)] --- path --- Nothing --- (_, True) -> do --- let decoded = (eitherDecode $ L.fromStrict responseBody) :: (Either String RestApiStatus) --- case decoded of --- Left err -> --- send $ --- responseLBS --- HttpTypes.status500 --- [("Content-Type", "application/json; charset=utf-8")] --- (encode $ RestApiStatus err "Internal Server Error") --- Right status -> --- let location = --- "/error?dest=" <> HttpTypes.urlEncode True (rawPathInfo req) --- <> "&message=" --- <> HttpTypes.urlEncode True (S8.pack $ message status) --- in send $ responseLBS HttpTypes.status303 [("Location", location)] "" --- (_, False) -> --- send $ --- responseLBS --- (HttpTypes.mkStatus responseStatusCode responseStatusMessage) --- [("Content-Type", "application/json; charset=utf-8")] --- (L.fromStrict responseBody) diff --git a/src/Handler/Upload.hs b/src/Handler/Upload.hs index 84e6ee9..2f09e87 100644 --- a/src/Handler/Upload.hs +++ b/src/Handler/Upload.hs @@ -27,7 +27,6 @@ import Foundation (App (App, fileSystemServiceClient), Handler) import Models.Inode (Inode (fileSystemId)) import Network.HTTP.Types (Status (Status)) import Utils.FileUtils (filterFiles) -import Utils.ResponeUtils (sendInternalError) import Yesod.Core ( FileInfo, MonadHandler, @@ -42,6 +41,7 @@ import Yesod.Core sendResponseStatus, ) import Yesod.Core.Handler (sendResponseCreated) +import Utils.HandlerUtils postUploadR :: Int -> Handler Value postUploadR parentId = do diff --git a/src/Models/Inode.hs b/src/Models/Inode.hs index b9c8f4f..af07d37 100644 --- a/src/Models/Inode.hs +++ b/src/Models/Inode.hs @@ -1,10 +1,9 @@ {-# LANGUAGE DeriveGeneric #-} -module Models.Inode where +module Models.Inode where import Data.Aeson import GHC.Generics - import Models.User data Inode = Inode diff --git a/src/Utils/FileUtils.sh b/src/Utils/FileUtils.sh deleted file mode 100644 index f1f641a..0000000 --- a/src/Utils/FileUtils.sh +++ /dev/null @@ -1 +0,0 @@ -#!/usr/bin/env bash diff --git a/src/Utils/HandlerUtils.hs b/src/Utils/HandlerUtils.hs new file mode 100644 index 0000000..84b054f --- /dev/null +++ b/src/Utils/HandlerUtils.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | +module Utils.HandlerUtils where + +import ClassyPrelude +import Data.Aeson +import Foundation +import Models.RestApiStatus +import Network.HTTP.Types +import Network.Wai (rawPathInfo) +import Yesod + +sendInternalError :: MonadHandler m => m a +sendInternalError = sendResponseStatus (Status 500 "Internal Server Error.") $ toJSON $ RestApiStatus "Internal Server Error" "500" + +handleApiCall :: (MonadHandler m, FromJSON a, RedirectUrl (HandlerSite m) (Route App, [(Text, Text)])) => Value -> Int -> ByteString -> m a +handleApiCall body statusCode statusMessage + | 200 <= statusCode && statusCode < 299 = + case fromJSON body of + Success value -> + return value + Error _ -> sendInternalError + | 400 <= statusCode && statusCode < 500 = sendErrorOrRedirect (Status statusCode statusMessage) body --sendResponseStatus (Status statusCode statusMessage) body + | otherwise = sendInternalError + +sendErrorOrRedirect :: (MonadHandler m, RedirectUrl (HandlerSite m) (Route App, [(Text, Text)])) => Status -> Value -> m a +sendErrorOrRedirect status body = + lookupContentType "text/html" >>= \case + True -> do + case fromJSON body of + Success value -> do + rawPathInfo <- decodeUtf8 . rawPathInfo . reqWaiRequest <$> getRequest + redirect (ErrorR, [("dest" :: Text, rawPathInfo :: Text), ("message" :: Text, pack $ message value :: Text)]) + Error _ -> sendInternalError + False -> sendResponseStatus status body + +lookupAuth :: MonadHandler m => m Text +lookupAuth = do + authToken <- lookupCookie "token" + authTokenParam <- lookupGetParam "token" + maybe (maybe notAuthenticated return authTokenParam) return authToken + +lookupContentType :: MonadHandler m => ContentType -> m Bool +lookupContentType contentType = + elem contentType . reqAccept <$> getRequest diff --git a/src/Utils/RequestUtils.hs b/src/Utils/RequestUtils.hs deleted file mode 100644 index d185d65..0000000 --- a/src/Utils/RequestUtils.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - - -module Utils.RequestUtils where - -import qualified Data.ByteString.Char8 as S8 -import qualified Network.HTTP.Types as HttpTypes -import Data.CaseInsensitive -import System.Environment - -getOneHeader :: [HttpTypes.Header] -> String -> S8.ByteString -getOneHeader headers headerName = - case Prelude.filter (\n -> fst n == (Data.CaseInsensitive.mk (S8.pack headerName) :: CI S8.ByteString)) headers of - [header] -> snd header - _ -> "" -httpConfigDontCheckResponse :: p1 -> p2 -> p3 -> Maybe a -httpConfigDontCheckResponse _ _ _ = Nothing - -getRestUrl :: IO String -getRestUrl = head <$> getArgs diff --git a/src/Utils/ResponeUtils.hs b/src/Utils/ResponeUtils.hs deleted file mode 100644 index 3e68438..0000000 --- a/src/Utils/ResponeUtils.hs +++ /dev/null @@ -1,10 +0,0 @@ --- | -{-# LANGUAGE OverloadedStrings #-} - -module Utils.ResponeUtils where -import Yesod -import Network.HTTP.Types -import Models.RestApiStatus - -sendInternalError :: MonadHandler m => m a -sendInternalError =sendResponseStatus (Status 500 "Internal Server Error.") $ toJSON $ RestApiStatus "Internal Server Error" "500" From 269a2c6196022a09768e2aa9217b06496cccd539 Mon Sep 17 00:00:00 2001 From: qvalentin Date: Sun, 6 Feb 2022 10:45:15 +0100 Subject: [PATCH 06/35] cleaner imports --- app/Main.hs | 1 + package.yaml | 2 ++ src/Application.hs | 1 + src/FileStorage.hs | 12 ++++++--- .../FileSystemServiceClient.hs | 20 ++++++++++++++- src/Foundation.hs | 2 +- src/Handler/Delete.hs | 10 +++----- src/Handler/Download.hs | 13 ---------- src/Handler/Error.hs | 1 + src/Handler/Health.hs | 10 +++----- src/Handler/Home.hs | 1 + src/Handler/Preview.hs | 12 +++++++++ src/Handler/Upload.hs | 7 +++--- src/Logger.hs | 4 +-- src/Models/Inode.hs | 2 +- src/Models/RestApiStatus.hs | 4 ++- src/Models/User.hs | 3 ++- src/Utils/FileUtils.hs | 12 --------- src/Utils/HandlerUtils.hs | 25 +++++++++++++++++++ 19 files changed, 90 insertions(+), 52 deletions(-) delete mode 100644 src/Utils/FileUtils.hs diff --git a/app/Main.hs b/app/Main.hs index 68a03c8..9c4a572 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,5 +1,6 @@ import Foundation import Application (appMain) +import ClassyPrelude main :: IO () main = appMain diff --git a/package.yaml b/package.yaml index b1683cd..3484dc1 100644 --- a/package.yaml +++ b/package.yaml @@ -46,3 +46,5 @@ executables: - -with-rtsopts=-N dependencies: - FileHandlerYesod + +default-extensions: NoImplicitPrelude diff --git a/src/Application.hs b/src/Application.hs index 9d7f8ab..430af6c 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -4,6 +4,7 @@ module Application where +import ClassyPrelude import Data.Yaml.Config import FileSystemServiceClient.FileSystemServiceClient (makeFileSystemServiceClient) import Foundation diff --git a/src/FileStorage.hs b/src/FileStorage.hs index d4125fb..0724d08 100644 --- a/src/FileStorage.hs +++ b/src/FileStorage.hs @@ -1,8 +1,8 @@ -- | module FileStorage where +import ClassyPrelude import Yesod -import Data.ByteString import Models.Inode import ClassyPrelude.Yesod import System.Directory @@ -13,7 +13,7 @@ import Data.Time storeFile :: MonadResource m => Inode -> IO (ConduitT ByteString o m ()) storeFile inode = do let id = show $ fileSystemId inode - createDirectoryIfMissing True [Prelude.head id] + createDirectoryIfMissing True $ take 1 id return $sinkFile (getPathFromFileId id) @@ -23,9 +23,15 @@ retrieveFile inode= do sourceFile (getPathFromFileId id) getPathFromFileId :: String -> String -getPathFromFileId id=Prelude.head id : ("/" Prelude.++id) +getPathFromFileId id=take 1 id ++ ("/" ++id) getInodeModifcationTime :: Inode -> IO UTCTime getInodeModifcationTime inode = do let id = show $ fileSystemId inode getModificationTime (getPathFromFileId id) + + +filterFiles :: Inode -> Bool +filterFiles file = case filesystemType file of + "FOLDER" -> False + _ -> True diff --git a/src/FileSystemServiceClient/FileSystemServiceClient.hs b/src/FileSystemServiceClient/FileSystemServiceClient.hs index 50b9d83..acb6e7f 100644 --- a/src/FileSystemServiceClient/FileSystemServiceClient.hs +++ b/src/FileSystemServiceClient/FileSystemServiceClient.hs @@ -13,7 +13,25 @@ import Data.ByteString.Char8 (ByteString) import Data.Text import Data.Text.Encoding (encodeUtf8) import GHC.Generics -import Network.HTTP.Req hiding (port) +import Network.HTTP.Req + ( (/:), + (=:), + defaultHttpConfig, + header, + http, + jsonResponse, + req, + responseBody, + responseHeader, + responseStatusCode, + responseStatusMessage, + runReq, + DELETE(DELETE), + GET(GET), + HttpConfig(httpConfigCheckResponse), + NoReqBody(NoReqBody), + POST(POST), + ReqBodyJson(ReqBodyJson) ) import qualified Network.HTTP.Req as Req import Settings import ClassyPrelude hiding (pack, encodeUtf8) diff --git a/src/Foundation.hs b/src/Foundation.hs index da7a31f..9bd87e7 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -5,6 +5,7 @@ module Foundation where +import ClassyPrelude import FileSystemServiceClient.FileSystemServiceClient ( FileSystemServiceClient, ) @@ -19,7 +20,6 @@ import Yesod.Core mkYesodData, parseRoutesFile, ) -import Network.HTTP.Req data App = App { appSettings :: AppSettings, diff --git a/src/Handler/Delete.hs b/src/Handler/Delete.hs index 9c47d45..1c04727 100644 --- a/src/Handler/Delete.hs +++ b/src/Handler/Delete.hs @@ -5,20 +5,18 @@ import Foundation import Yesod.Core +import ClassyPrelude hiding (filter, Handler) import qualified Data.Text as DataText import Data.Aeson import Data.Maybe (fromMaybe) import Models.Inode import Network.HTTP.Req -import Network.Wai -import Utils.FileUtils -import Logger -import Models.RestApiStatus import System.Directory import FileSystemServiceClient.FileSystemServiceClient import Network.HTTP.Types -import Data.ByteString import Utils.HandlerUtils +import FileStorage (filterFiles, getPathFromFileId) +import Prelude (filter) @@ -36,7 +34,7 @@ deleteDeleteR inodeId = do 200 -> do case fromJSON responseBody of Success inodes -> do - liftIO $ mapM_ deleteFile (Prelude.filter filterFiles inodes) -- Todo: check if file exists + liftIO $ mapM_ deleteFile (filter filterFiles inodes) -- Todo: check if file exists return responseBody Error _ -> sendInternalError _ -> sendResponseStatus (Status responseStatusCode responseStatusMessage) responseBody diff --git a/src/Handler/Download.hs b/src/Handler/Download.hs index 6d5689e..34e2b93 100644 --- a/src/Handler/Download.hs +++ b/src/Handler/Download.hs @@ -53,12 +53,7 @@ import Codec.Archive.Zip.Conduit.Zip ZipOptions (..), zipStream, ) -import Data.Aeson () import qualified Data.ByteString.Char8 as S8 -import qualified Data.ByteString.Lazy as L -import Data.CaseInsensitive () -import Data.Maybe () -import qualified Data.Text as DataText import Data.Time (TimeZone, getCurrentTimeZone, utcToLocalTime) import FileStorage (getInodeModifcationTime, retrieveFile) import FileSystemServiceClient.FileSystemServiceClient @@ -68,21 +63,13 @@ import FileSystemServiceClient.FileSystemServiceClient ), ) import Foundation (App (App, fileSystemServiceClient), Handler) -import Logger () import Models.Inode ( Inode(lastUpdated, mimeType, name, size,path) ) -import Models.RestApiStatus () -import Network.HTTP.Req () import qualified Network.HTTP.Types as HttpTypes -import Network.Wai () import System.Directory (doesDirectoryExist, removeFile) -import System.Environment () -import System.IO () import System.IO.Temp (emptySystemTempFile) import UnliftIO.Resource (allocate) -import Utils.FileUtils () import Utils.HandlerUtils (handleApiCall, lookupAuth) -import Yesod.Core () getDownloadR :: Handler ClassyPrelude.Yesod.TypedContent getDownloadR = do diff --git a/src/Handler/Error.hs b/src/Handler/Error.hs index d799d9c..62303f8 100644 --- a/src/Handler/Error.hs +++ b/src/Handler/Error.hs @@ -2,6 +2,7 @@ module Handler.Error where import Foundation +import ClassyPrelude hiding (Handler) getErrorR :: Handler () getErrorR = return () diff --git a/src/Handler/Health.hs b/src/Handler/Health.hs index c0f3b01..bdfb38c 100644 --- a/src/Handler/Health.hs +++ b/src/Handler/Health.hs @@ -5,15 +5,11 @@ module Handler.Health where import Foundation +import ClassyPrelude hiding (Handler) import Yesod.Core import qualified Network.HTTP.Types as HttpTypes -import Network.Wai -import Data.Aeson -import System.Environment import System.Directory -import System.FilePath -import Control.Monad -import GHC.Generics + ( doesDirectoryExist, getFileSize, listDirectory ) import Settings (AppSettings(AppSettings), appProfile) @@ -43,4 +39,4 @@ getHealthR = do listDirectoryRelative :: FilePath -> IO [FilePath] -listDirectoryRelative x = Prelude.map (x ) <$> listDirectory x +listDirectoryRelative x = map (x ) <$> listDirectory x diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 2d77e84..87c438b 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -4,6 +4,7 @@ module Handler.Home where import Foundation import Yesod.Core +import ClassyPrelude hiding (Handler) diff --git a/src/Handler/Preview.hs b/src/Handler/Preview.hs index 8d6792c..eb3351f 100644 --- a/src/Handler/Preview.hs +++ b/src/Handler/Preview.hs @@ -3,6 +3,18 @@ module Handler.Preview where import ClassyPrelude.Yesod + ( ($), + Show(show), + Int, + getYesod, + (.|), + MonadIO(liftIO), + String, + fromMaybe, + awaitForever, + respondSource, + sendChunkBS, + TypedContent ) import qualified Data.ByteString.Char8 as S8 import FileStorage (retrieveFile) import Foundation diff --git a/src/Handler/Upload.hs b/src/Handler/Upload.hs index 2f09e87..8598022 100644 --- a/src/Handler/Upload.hs +++ b/src/Handler/Upload.hs @@ -3,7 +3,7 @@ -- | module Handler.Upload where -import ClassyPrelude.Conduit (runConduit, sinkFile, (.|)) +import ClassyPrelude hiding (Handler) import ClassyPrelude.Yesod ( FileInfo (fileContentType), runConduitRes, @@ -18,7 +18,7 @@ import Data.Aeson import qualified Data.ByteString.Char8 as S8 import Data.CaseInsensitive (mk) import qualified Data.Text as Text -import FileStorage (storeFile) +import FileStorage (storeFile,filterFiles) import FileSystemServiceClient.FileSystemServiceClient ( FileSystemServiceClient (FileSystemServiceClient, createInode), UploadedInode (UploadedInode), @@ -26,7 +26,6 @@ import FileSystemServiceClient.FileSystemServiceClient import Foundation (App (App, fileSystemServiceClient), Handler) import Models.Inode (Inode (fileSystemId)) import Network.HTTP.Types (Status (Status)) -import Utils.FileUtils (filterFiles) import Yesod.Core ( FileInfo, MonadHandler, @@ -63,7 +62,7 @@ postUploadR parentId = do 201 -> do case fromJSON responseBody of Success createdInodes -> do - case Prelude.filter filterFiles createdInodes of + case filter filterFiles createdInodes of [singleInode] -> do let a = fileSystemId singleInode fileDest <- liftIO $ storeFile singleInode diff --git a/src/Logger.hs b/src/Logger.hs index 590b076..af2ee22 100644 --- a/src/Logger.hs +++ b/src/Logger.hs @@ -1,9 +1,9 @@ -- | module Logger where -import System.IO (hFlush, stdout) +import ClassyPrelude -logStdOut :: String -> IO () +logStdOut :: Text -> IO () logStdOut text = do putStrLn text hFlush stdout diff --git a/src/Models/Inode.hs b/src/Models/Inode.hs index af07d37..0135241 100644 --- a/src/Models/Inode.hs +++ b/src/Models/Inode.hs @@ -2,8 +2,8 @@ module Models.Inode where +import ClassyPrelude import Data.Aeson -import GHC.Generics import Models.User data Inode = Inode diff --git a/src/Models/RestApiStatus.hs b/src/Models/RestApiStatus.hs index a83f686..5ecc991 100644 --- a/src/Models/RestApiStatus.hs +++ b/src/Models/RestApiStatus.hs @@ -1,10 +1,12 @@ {-# LANGUAGE DeriveGeneric #-} -- | + module Models.RestApiStatus where +import ClassyPrelude + import Data.Aeson -import GHC.Generics data RestApiStatus = RestApiStatus { message :: !String, diff --git a/src/Models/User.hs b/src/Models/User.hs index a7d661c..ff7c366 100644 --- a/src/Models/User.hs +++ b/src/Models/User.hs @@ -1,8 +1,9 @@ {-# LANGUAGE DeriveGeneric #-} module Models.User where +import ClassyPrelude + import Data.Aeson -import GHC.Generics data User = User { userId :: Int, diff --git a/src/Utils/FileUtils.hs b/src/Utils/FileUtils.hs deleted file mode 100644 index 72ebcb9..0000000 --- a/src/Utils/FileUtils.hs +++ /dev/null @@ -1,12 +0,0 @@ --- | - -module Utils.FileUtils where -import Models.Inode - -getPathFromFileId :: String -> String -getPathFromFileId id=head id : ("/" ++id) - -filterFiles :: Inode -> Bool -filterFiles file = case filesystemType file of - "FOLDER" -> False - _ -> True diff --git a/src/Utils/HandlerUtils.hs b/src/Utils/HandlerUtils.hs index 84b054f..2574d0a 100644 --- a/src/Utils/HandlerUtils.hs +++ b/src/Utils/HandlerUtils.hs @@ -7,12 +7,37 @@ module Utils.HandlerUtils where import ClassyPrelude + ( otherwise, + ($), + Monad(return, (>>=)), + Ord((<), (<=)), + Bool(..), + Int, + (<$>), + ByteString, + Text, + (&&), + maybe, + (.), + elem, + pack, + Utf8(decodeUtf8) ) import Data.Aeson import Foundation import Models.RestApiStatus import Network.HTTP.Types import Network.Wai (rawPathInfo) import Yesod + ( sendResponseStatus, + notAuthenticated, + MonadHandler(HandlerSite), + getRequest, + lookupCookie, + lookupGetParam, + redirect, + RedirectUrl, + ContentType, + YesodRequest(reqWaiRequest, reqAccept) ) sendInternalError :: MonadHandler m => m a sendInternalError = sendResponseStatus (Status 500 "Internal Server Error.") $ toJSON $ RestApiStatus "Internal Server Error" "500" From 648b2abb21374ef39fa3e0fe9962c1833d82b460 Mon Sep 17 00:00:00 2001 From: qvalentin Date: Sun, 6 Feb 2022 10:58:56 +0100 Subject: [PATCH 07/35] move zip functions --- src/Handler/Download.hs | 83 +++++++---------------------------------- src/Utils/ZipFile.hs | 62 ++++++++++++++++++++++++++++++ 2 files changed, 75 insertions(+), 70 deletions(-) create mode 100644 src/Utils/ZipFile.hs diff --git a/src/Handler/Download.hs b/src/Handler/Download.hs index 34e2b93..a97958f 100644 --- a/src/Handler/Download.hs +++ b/src/Handler/Download.hs @@ -46,15 +46,7 @@ import ClassyPrelude.Yesod yield, (.|), ) -import Codec.Archive.Zip.Conduit.Zip - ( ZipData (ZipDataSource), - ZipEntry (..), - ZipInfo (ZipInfo, zipComment), - ZipOptions (..), - zipStream, - ) import qualified Data.ByteString.Char8 as S8 -import Data.Time (TimeZone, getCurrentTimeZone, utcToLocalTime) import FileStorage (getInodeModifcationTime, retrieveFile) import FileSystemServiceClient.FileSystemServiceClient ( FileSystemServiceClient @@ -64,16 +56,18 @@ import FileSystemServiceClient.FileSystemServiceClient ) import Foundation (App (App, fileSystemServiceClient), Handler) import Models.Inode - ( Inode(lastUpdated, mimeType, name, size,path) ) + ( Inode (lastUpdated, mimeType, name, path, size), + ) import qualified Network.HTTP.Types as HttpTypes import System.Directory (doesDirectoryExist, removeFile) import System.IO.Temp (emptySystemTempFile) import UnliftIO.Resource (allocate) import Utils.HandlerUtils (handleApiCall, lookupAuth) +import Utils.ZipFile -getDownloadR :: Handler ClassyPrelude.Yesod.TypedContent +getDownloadR :: Handler TypedContent getDownloadR = do - App {fileSystemServiceClient = FileSystemServiceClient {getInodeContent = getInodeContent}} <- ClassyPrelude.Yesod.getYesod + App {fileSystemServiceClient = FileSystemServiceClient {getInodeContent = getInodeContent}} <- getYesod bearerToken <- lookupAuth inodeIds <- lookupRequiredInodeIds @@ -81,14 +75,14 @@ getDownloadR = do inodes <- handleApiCall responseBody responseStatusCode responseStatusMessage case inodes of [singleInode] -> do - ClassyPrelude.Yesod.addHeader "Content-Disposition" $ pack ("attachment; filename=\"" ++ Models.Inode.name singleInode ++ "\"") - ClassyPrelude.Yesod.respondSource (S8.pack $ fromMaybe "application/octet-stream" (Models.Inode.mimeType singleInode)) $ - retrieveFile singleInode ClassyPrelude.Yesod..| ClassyPrelude.Yesod.awaitForever ClassyPrelude.Yesod.sendChunkBS + addHeader "Content-Disposition" $ pack ("attachment; filename=\"" ++ Models.Inode.name singleInode ++ "\"") + respondSource (S8.pack $ fromMaybe "application/octet-stream" (mimeType singleInode)) $ + retrieveFile singleInode .| awaitForever sendChunkBS multipleInodes -> do let archiveName = fromMaybe "Files" maybeFilename - ClassyPrelude.Yesod.addHeader "Content-Disposition" ("attachment; filename=\"" ++ decodeUtf8 archiveName ++ ".zip" ++ "\"") + addHeader "Content-Disposition" ("attachment; filename=\"" ++ decodeUtf8 archiveName ++ ".zip" ++ "\"") (_, tempFile) <- allocate (makeAllocateResource multipleInodes) freeResource - ClassyPrelude.Yesod.sendFile "application/zip" tempFile + sendFile "application/zip" tempFile makeAllocateResource :: [Models.Inode.Inode] -> IO FilePath makeAllocateResource inodes = do @@ -99,59 +93,8 @@ makeAllocateResource inodes = do freeResource :: FilePath -> IO () freeResource = removeFile -createZip :: [Models.Inode.Inode] -> FilePath -> IO () -createZip inodes filename = do - timeZone <- liftIO getCurrentTimeZone - ClassyPrelude.Yesod.runConduitRes $ - generateZipEntries inodes timeZone - ClassyPrelude.Yesod..| void (zipStream zipOptions) - ClassyPrelude.Yesod..| ClassyPrelude.Yesod.sinkFile filename - -generateZipEntries :: (MonadIO m, ClassyPrelude.Yesod.MonadResource m) => [Models.Inode.Inode] -> TimeZone -> ClassyPrelude.Yesod.ConduitM () (ZipEntry, ZipData m) m () -generateZipEntries (currentInode : nextInodes) timeZone = do - let nameInZip = fromMaybe (Models.Inode.name currentInode) $ Models.Inode.path currentInode - let size' = Models.Inode.size currentInode - timeStamp <- liftIO $ getTimestampForInode currentInode - let entry = - ZipEntry - { zipEntryName = Right $ fromString nameInZip, - zipEntryTime = utcToLocalTime timeZone timeStamp, - zipEntrySize = Nothing, -- Just (fromIntegral size'), - zipEntryExternalAttributes = Nothing - } - - ClassyPrelude.Yesod.yield (entry, ZipDataSource $retrieveFile currentInode) - generateZipEntries nextInodes timeZone - return () -generateZipEntries [] _ = return () - -zipOptions :: ZipOptions -zipOptions = - ZipOptions - { zipOpt64 = True, - zipOptCompressLevel = 9, - zipOptInfo = - ZipInfo - { zipComment = "" - } - } - -getTimestampForInode :: Models.Inode.Inode -> IO UTCTime -getTimestampForInode inode = do - let maybeTimeStamp = convertUnixTimeStamp (Models.Inode.lastUpdated inode) - case maybeTimeStamp of - Just timeStamp -> return timeStamp - Nothing -> getInodeModifcationTime inode - -convertUnixTimeStamp :: Int -> Maybe UTCTime -convertUnixTimeStamp ts = do - let i = parseTimeM True defaultTimeLocale "%s" (show ts) :: Maybe UTCTime - case i of - Just timeWithoutTimezone -> do - Just timeWithoutTimezone - Nothing -> Nothing -lookupRequiredInodeIds :: ClassyPrelude.Yesod.MonadHandler m => m String +lookupRequiredInodeIds :: MonadHandler m => m String lookupRequiredInodeIds = do - maybeIds <- ClassyPrelude.Yesod.lookupGetParam "ids" - maybe (ClassyPrelude.Yesod.invalidArgs ["Missing ids query parameter."]) return $ unpack <$> maybeIds + maybeIds <- lookupGetParam "ids" + maybe (invalidArgs ["Missing ids query parameter."]) return $ unpack <$> maybeIds diff --git a/src/Utils/ZipFile.hs b/src/Utils/ZipFile.hs new file mode 100644 index 0000000..8b023b2 --- /dev/null +++ b/src/Utils/ZipFile.hs @@ -0,0 +1,62 @@ +-- | +{-# LANGUAGE OverloadedStrings #-} + +module Utils.ZipFile where +import ClassyPrelude +import qualified Models.Inode +import Codec.Archive.Zip.Conduit.Zip +import ClassyPrelude.Conduit +import Data.Time +import FileStorage (retrieveFile, getInodeModifcationTime) + +createZip :: [Models.Inode.Inode] -> FilePath -> IO () +createZip inodes filename = do + timeZone <- liftIO getCurrentTimeZone + runConduitRes $ + generateZipEntries inodes timeZone + .| void (zipStream zipOptions) + .| sinkFile filename + +generateZipEntries :: (MonadIO m, MonadResource m) => [Models.Inode.Inode] -> TimeZone -> ConduitM () (ZipEntry, ZipData m) m () +generateZipEntries (currentInode : nextInodes) timeZone = do + let nameInZip = fromMaybe (Models.Inode.name currentInode) $ Models.Inode.path currentInode + let size' = Models.Inode.size currentInode + timeStamp <- liftIO $ getTimestampForInode currentInode + let entry = + ZipEntry + { zipEntryName = Right $ fromString nameInZip, + zipEntryTime = utcToLocalTime timeZone timeStamp, + zipEntrySize = Nothing, -- Just (fromIntegral size'), + zipEntryExternalAttributes = Nothing + } + + yield (entry, ZipDataSource $retrieveFile currentInode) + generateZipEntries nextInodes timeZone + return () +generateZipEntries [] _ = return () + +zipOptions :: ZipOptions +zipOptions = + ZipOptions + { zipOpt64 = True, + zipOptCompressLevel = 9, + zipOptInfo = + ZipInfo + { zipComment = "" + } + } + +getTimestampForInode :: Models.Inode.Inode -> IO UTCTime +getTimestampForInode inode = do + let maybeTimeStamp = convertUnixTimeStamp (Models.Inode.lastUpdated inode) + case maybeTimeStamp of + Just timeStamp -> return timeStamp + Nothing -> getInodeModifcationTime inode + +convertUnixTimeStamp :: Int -> Maybe UTCTime +convertUnixTimeStamp ts = do + let i = parseTimeM True defaultTimeLocale "%s" (show ts) :: Maybe UTCTime + case i of + Just timeWithoutTimezone -> do + Just timeWithoutTimezone + Nothing -> Nothing From d6d8f536422c57a3f32ab035cc34494fd7b1b385 Mon Sep 17 00:00:00 2001 From: qvalentin Date: Sun, 6 Feb 2022 15:20:47 +0100 Subject: [PATCH 08/35] Encryption is working --- config/settings.yml | 2 + package.yaml | 2 + src/Application.hs | 13 +++++- src/Crypto/CryptoConduit.hs | 74 +++++++++++++++++++++++++++++++++ src/Crypto/Init.hs | 19 +++++++++ src/Crypto/KeyEncrptionKey.hs | 78 +++++++++++++++++++++++++++++++++++ src/Crypto/Random.hs | 25 +++++++++++ src/Crypto/Types.hs | 9 ++++ src/FileStorage.hs | 3 +- src/Foundation.hs | 4 +- src/Handler/Download.hs | 61 ++++++++++++++++++++++----- src/Handler/Upload.hs | 50 ++++++++++++++++++---- src/Settings.hs | 3 +- src/Utils/ZipFile.hs | 11 +++-- 14 files changed, 327 insertions(+), 27 deletions(-) create mode 100644 src/Crypto/CryptoConduit.hs create mode 100644 src/Crypto/Init.hs create mode 100644 src/Crypto/KeyEncrptionKey.hs create mode 100644 src/Crypto/Random.hs create mode 100644 src/Crypto/Types.hs diff --git a/config/settings.yml b/config/settings.yml index bad2be1..fee6c43 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -5,3 +5,5 @@ appProfile: "_env:APP_PROFILE:prod" fileSystemServiceSettings: url: "_env:FILESYSTEMSERVICE_URL:localhost" port: "_env:FILESYSTEMSERVICE_PORT:8080" + +encryptionPassword: "_env:ENCRYPTION_PASSWORD:changeThis" diff --git a/package.yaml b/package.yaml index 3484dc1..bfba80e 100644 --- a/package.yaml +++ b/package.yaml @@ -27,6 +27,8 @@ dependencies: - file-embed - zip-stream - time +- cryptonite +- memory diff --git a/src/Application.hs b/src/Application.hs index 430af6c..61cb6e7 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -5,17 +5,21 @@ module Application where import ClassyPrelude +import Crypto.KeyEncrptionKey (createKeyEncrptionKey, getOrCreateKekIV) import Data.Yaml.Config import FileSystemServiceClient.FileSystemServiceClient (makeFileSystemServiceClient) import Foundation import Handler.Delete import Handler.Download +import Handler.Error import Handler.Health import Handler.Home import Handler.Preview import Handler.Upload -import Handler.Error import Settings + ( AppSettings (encryptionPassword, fileSystemServiceSettings), + configSettingsYmlValue, + ) import Yesod.Core mkYesodDispatch "App" resourcesApp @@ -23,10 +27,15 @@ mkYesodDispatch "App" resourcesApp makeFoundation :: AppSettings -> IO App makeFoundation appSettings = do let fssC = makeFileSystemServiceClient (fileSystemServiceSettings appSettings) + + iv <- getOrCreateKekIV + let keyEncrptionKey = createKeyEncrptionKey (encryptionPassword appSettings) iv + return App { appSettings = appSettings, - fileSystemServiceClient = fssC + fileSystemServiceClient = fssC, + keyEncrptionKey = keyEncrptionKey } appMain :: IO () diff --git a/src/Crypto/CryptoConduit.hs b/src/Crypto/CryptoConduit.hs new file mode 100644 index 0000000..50b543f --- /dev/null +++ b/src/Crypto/CryptoConduit.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | + +module Crypto.CryptoConduit where +import ClassyPrelude + ( ($), + Integral(div), + Monad((>>=), return), + Num((-), (+), (*)), + Ord(max), + Semigroup((<>)), + Maybe(Just, Nothing), + maybe, + fromMaybe, + IsSequence(drop, splitAt), + MonadIO, + ByteString, + error, + length, + null, + (.) ) +import ClassyPrelude.Conduit + ( ($), + Integral(div), + Monad((>>=), return), + Num((-), (+), (*)), + Ord(max), + Semigroup((<>)), + Maybe(Just, Nothing), + ByteString, + MonadIO, + ConduitT, + (.), + fromMaybe, + maybe, + error, + length, + null, + IsSequence(drop, splitAt), + await, + yield ) +import Crypto.Cipher.Types +import Crypto.Data.Padding + +encryptConduit :: (BlockCipher c, Monad m) => c -> IV c -> ByteString -> ConduitT ByteString ByteString m () +encryptConduit cipher iv partialBlock = await >>= \case + Nothing -> yield $ cbcEncrypt cipher iv $ pad (PKCS7 (blockSize cipher)) partialBlock + Just moreBytes -> let + fullBlocks = (length moreBytes + length partialBlock) `div` blockSize cipher + (thisTime, nextTime) = splitAt (fullBlocks * blockSize cipher) (partialBlock <> moreBytes) + in do + iv' <- if null thisTime then return iv else do + let cipherText = cbcEncrypt cipher iv thisTime + lastBlockOfCipherText = drop (length cipherText - blockSize cipher) cipherText + yield cipherText + maybe (error "makeIV failed") return $ makeIV lastBlockOfCipherText + encryptConduit cipher iv' nextTime + +decryptConduit :: (BlockCipher c, MonadIO m) => c -> IV c -> ByteString -> ConduitT ByteString ByteString m () +decryptConduit cipher iv partialBlock = await >>= \case + Nothing -> if null partialBlock then return () else yield $ removePadding $ cbcDecrypt cipher iv partialBlock + Just moreBytes -> let + fullBlocks = (length moreBytes + length partialBlock) `div` blockSize cipher + (thisTime, nextTime) = splitAt ( max 0 (fullBlocks-1) * blockSize cipher) (partialBlock <> moreBytes) + in do + iv' <- if null thisTime then return iv else do + let plainText = cbcDecrypt cipher iv thisTime + lastBlockOfCipherText = drop (length thisTime - blockSize cipher) thisTime + yield plainText + maybe (error "makeIV failed") return $ makeIV lastBlockOfCipherText + decryptConduit cipher iv' nextTime + where removePadding = fromMaybe "hallo da " . unpad (PKCS7 (blockSize cipher)) diff --git a/src/Crypto/Init.hs b/src/Crypto/Init.hs new file mode 100644 index 0000000..08e311a --- /dev/null +++ b/src/Crypto/Init.hs @@ -0,0 +1,19 @@ +-- | + +module Crypto.Init where +import ClassyPrelude +import Crypto.Cipher.Types +import Crypto.Types (Key(Key)) +import Data.ByteArray +import Crypto.Error + +initIV :: (BlockCipher c) => ByteString -> IV c +initIV ivBytes = do + case makeIV ivBytes of + Nothing -> error "Failed to generate initialization vector." + Just iv -> iv + +initCipher :: (BlockCipher c, ByteArray a) => Key c a -> c +initCipher (Key k) = case cipherInit k of + CryptoFailed e -> error "Failed to initialize cipher" + CryptoPassed a -> a diff --git a/src/Crypto/KeyEncrptionKey.hs b/src/Crypto/KeyEncrptionKey.hs new file mode 100644 index 0000000..4be23d4 --- /dev/null +++ b/src/Crypto/KeyEncrptionKey.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-deprecations #-} + +-- | +module Crypto.KeyEncrptionKey where + +import ClassyPrelude +import Crypto.Cipher.AES +import Crypto.Cipher.Types +import Crypto.Data.Padding +import Crypto.Error +import Crypto.KDF.BCryptPBKDF (Parameters (Parameters), generate) +import Crypto.Random (genRandomIV) +import Crypto.Types (Key (Key)) +import Data.ByteArray +import System.Directory (doesFileExist) +import Models.Inode +import FileStorage (getPathFromFileId) +import Crypto.Init (initCipher, initIV) + +kekSalt :: ByteString +kekSalt = "FileFighterFileHandlerWithSomeSalt" + +data KeyEncryptionKey = KeyEncryptionKey + { blockCipher :: AES256, + initialIV :: IV AES256 + } + + +-- This should use the database later +getOrCreateKekIV :: IO ByteString +getOrCreateKekIV = do + exists <- doesFileExist "kek.iv" + if exists + then readFile "kek.iv" + else do + ivBytes <- genRandomIV (undefined :: AES256) + writeFile "kek.iv" ivBytes + return ivBytes + +createKeyEncrptionKey :: String -> ByteString -> KeyEncryptionKey +createKeyEncrptionKey password ivBytes = do + let mInitIV = makeIV ivBytes + case mInitIV of + Nothing -> error "Failed to generate initialization vector for encrpting the keys." + Just initIV -> do + let secretKey :: Key AES256 ByteString = Key $ generateKeyfromPassword (fromString password) + KeyEncryptionKey + { blockCipher = initCipher secretKey , + initialIV = initIV + } + +generateKeyfromPassword :: (ByteArray output) => ByteString -> output +generateKeyfromPassword password = do + let params = Parameters 4 32 + generate params password kekSalt + +encryptWithKek :: KeyEncryptionKey -> ByteString -> ByteString +encryptWithKek r@KeyEncryptionKey {blockCipher = cipher, initialIV = iv} = do + cbcEncrypt cipher iv . pad (PKCS7 (blockSize cipher)) + +decryptWithKek :: KeyEncryptionKey -> ByteString -> ByteString +decryptWithKek r@KeyEncryptionKey {blockCipher = cipher, initialIV = iv} message = do + let decrypted = cbcDecrypt cipher iv message + fromMaybe + decrypted + (unpad (PKCS7 (blockSize cipher)) decrypted) + + + +getKeyForInode :: KeyEncryptionKey -> Inode -> IO (AES256, IV AES256) +getKeyForInode kek inode = do + key <- decryptWithKek kek <$> readFile (getPathFromFileId (show $ fileSystemId inode) ++ ".key") + iv <- readFile (getPathFromFileId (show $ fileSystemId inode) ++ ".iv") + + return (initCipher $ Key key, initIV iv) diff --git a/src/Crypto/Random.hs b/src/Crypto/Random.hs new file mode 100644 index 0000000..7b0b46b --- /dev/null +++ b/src/Crypto/Random.hs @@ -0,0 +1,25 @@ +-- | +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-deprecations #-} + +module Crypto.Random where +import ClassyPrelude +import Crypto.Random.Types +import Crypto.Cipher.Types +import Data.ByteArray +import Crypto.Types (Key (Key)) + +-- | Generates a string of bytes (key) of a specific length for a given block cipher +genSecretKey :: forall m c a. (MonadRandom m, BlockCipher c, ByteArray a) => c -- ^ + -> Int -- ^ + -> m (Key c a) +genSecretKey _ = fmap Key . getRandomBytes + +-- | Generate a random initialization vector for a given block cipher +genRandomIV :: forall m c. (MonadRandom m, BlockCipher c) => c -> m ByteString +genRandomIV _ = do + bytes :: ByteString <- getRandomBytes $ blockSize (undefined :: c) + return bytes diff --git a/src/Crypto/Types.hs b/src/Crypto/Types.hs new file mode 100644 index 0000000..b3b40d2 --- /dev/null +++ b/src/Crypto/Types.hs @@ -0,0 +1,9 @@ +-- | +{-# LANGUAGE GADTs #-} + +module Crypto.Types where +import Crypto.Cipher.Types +import Data.ByteArray + +data Key c a where + Key :: (BlockCipher c, ByteArray a) => a -> Key c a diff --git a/src/FileStorage.hs b/src/FileStorage.hs index 0724d08..5a880d4 100644 --- a/src/FileStorage.hs +++ b/src/FileStorage.hs @@ -7,6 +7,7 @@ import Models.Inode import ClassyPrelude.Yesod import System.Directory import Data.Time +import GHC.IO.FD (openFile) @@ -14,7 +15,7 @@ storeFile :: MonadResource m => Inode -> IO (ConduitT ByteString o m ()) storeFile inode = do let id = show $ fileSystemId inode createDirectoryIfMissing True $ take 1 id - return $sinkFile (getPathFromFileId id) + return $sinkFileCautious (getPathFromFileId id) retrieveFile :: MonadResource m => Inode ->ConduitT i ByteString m () diff --git a/src/Foundation.hs b/src/Foundation.hs index 9bd87e7..77dda46 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -20,10 +20,12 @@ import Yesod.Core mkYesodData, parseRoutesFile, ) +import Crypto.KeyEncrptionKey (KeyEncryptionKey) data App = App { appSettings :: AppSettings, - fileSystemServiceClient :: FileSystemServiceClient + fileSystemServiceClient :: FileSystemServiceClient, + keyEncrptionKey :: KeyEncryptionKey } mkYesodData "App" $(parseRoutesFile "routes.yesodroutes") diff --git a/src/Handler/Download.hs b/src/Handler/Download.hs index a97958f..1507f72 100644 --- a/src/Handler/Download.hs +++ b/src/Handler/Download.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TupleSections #-} module Handler.Download where @@ -26,7 +27,7 @@ import ClassyPrelude void, ($), (++), - (<$>), + (<$>) ) import ClassyPrelude.Yesod ( ConduitM, @@ -47,16 +48,16 @@ import ClassyPrelude.Yesod (.|), ) import qualified Data.ByteString.Char8 as S8 -import FileStorage (getInodeModifcationTime, retrieveFile) +import FileStorage (getInodeModifcationTime, retrieveFile, getPathFromFileId) import FileSystemServiceClient.FileSystemServiceClient ( FileSystemServiceClient ( FileSystemServiceClient, getInodeContent ), ) -import Foundation (App (App, fileSystemServiceClient), Handler) +import Foundation (App (App, fileSystemServiceClient, keyEncrptionKey), Handler) import Models.Inode - ( Inode (lastUpdated, mimeType, name, path, size), + ( Inode (lastUpdated, mimeType, name, path, size), fileSystemId ) import qualified Network.HTTP.Types as HttpTypes import System.Directory (doesDirectoryExist, removeFile) @@ -64,10 +65,36 @@ import System.IO.Temp (emptySystemTempFile) import UnliftIO.Resource (allocate) import Utils.HandlerUtils (handleApiCall, lookupAuth) import Utils.ZipFile +import Crypto.Cipher.AES +import Crypto.Cipher.Types +import Crypto.KeyEncrptionKey (KeyEncryptionKey, decryptWithKek) +import ClassyPrelude + ( ($), + Monad(return), + Functor(fmap), + Show(show), + Traversable(mapM), + Monoid(mempty), + IO, + String, + MonadIO(liftIO), + fromMaybe, + maybe, + FilePath, + (<$>), + (++), + readFile, + tshow, + pack, + unpack, + Utf8(decodeUtf8) ) +import Crypto.Init +import Crypto.Types (Key(Key)) +import Crypto.CryptoConduit (decryptConduit) getDownloadR :: Handler TypedContent getDownloadR = do - App {fileSystemServiceClient = FileSystemServiceClient {getInodeContent = getInodeContent}} <- getYesod + App {fileSystemServiceClient = FileSystemServiceClient {getInodeContent = getInodeContent}, keyEncrptionKey = kek} <- getYesod bearerToken <- lookupAuth inodeIds <- lookupRequiredInodeIds @@ -76,18 +103,23 @@ getDownloadR = do case inodes of [singleInode] -> do addHeader "Content-Disposition" $ pack ("attachment; filename=\"" ++ Models.Inode.name singleInode ++ "\"") + addHeader "Content-Length" $ tshow $ size singleInode + (key, iv) <- liftIO $ getKeyForInode kek singleInode respondSource (S8.pack $ fromMaybe "application/octet-stream" (mimeType singleInode)) $ - retrieveFile singleInode .| awaitForever sendChunkBS + retrieveFile singleInode + .| decryptConduit key iv mempty + .| awaitForever sendChunkBS multipleInodes -> do let archiveName = fromMaybe "Files" maybeFilename addHeader "Content-Disposition" ("attachment; filename=\"" ++ decodeUtf8 archiveName ++ ".zip" ++ "\"") - (_, tempFile) <- allocate (makeAllocateResource multipleInodes) freeResource + (_, tempFile) <- allocate (makeAllocateResource kek multipleInodes) freeResource sendFile "application/zip" tempFile -makeAllocateResource :: [Models.Inode.Inode] -> IO FilePath -makeAllocateResource inodes = do +makeAllocateResource :: KeyEncryptionKey -> [Models.Inode.Inode] -> IO FilePath +makeAllocateResource kek inodes = do path <- emptySystemTempFile "FileFighterFileHandler.zip" - createZip inodes path + inodesWithKeys <- mapM (\inode -> fmap (inode,) (getKeyForInode kek inode)) inodes + createZip inodesWithKeys path return path freeResource :: FilePath -> IO () @@ -98,3 +130,12 @@ lookupRequiredInodeIds :: MonadHandler m => m String lookupRequiredInodeIds = do maybeIds <- lookupGetParam "ids" maybe (invalidArgs ["Missing ids query parameter."]) return $ unpack <$> maybeIds + + + +getKeyForInode :: KeyEncryptionKey -> Inode -> IO (AES256, IV AES256) +getKeyForInode kek inode = do + key <- decryptWithKek kek <$> readFile (getPathFromFileId (show $ fileSystemId inode) ++ ".key") + iv <- readFile (getPathFromFileId (show $ fileSystemId inode) ++ ".iv") + + return (initCipher $ Key key, initIV iv) diff --git a/src/Handler/Upload.hs b/src/Handler/Upload.hs index 8598022..ed7799a 100644 --- a/src/Handler/Upload.hs +++ b/src/Handler/Upload.hs @@ -1,31 +1,45 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-deprecations #-} -- | module Handler.Upload where import ClassyPrelude hiding (Handler) import ClassyPrelude.Yesod - ( FileInfo (fileContentType), + ( ConduitT, + FileInfo (fileContentType), runConduitRes, (.|), ) +import Crypto.Cipher.AES +import Crypto.Cipher.Types (BlockCipher, IV, cipherInit, makeIV) +import Crypto.CryptoConduit (encryptConduit) +import Crypto.Error +import Crypto.KeyEncrptionKey hiding (initCipher, initIV) +import Crypto.Random +import Crypto.Types import Data.Aeson ( Result (Error, Success), Value, fromJSON, object, ) +import Data.ByteArray import qualified Data.ByteString.Char8 as S8 import Data.CaseInsensitive (mk) import qualified Data.Text as Text -import FileStorage (storeFile,filterFiles) +import FileStorage (filterFiles, getPathFromFileId, storeFile) import FileSystemServiceClient.FileSystemServiceClient ( FileSystemServiceClient (FileSystemServiceClient, createInode), UploadedInode (UploadedInode), ) -import Foundation (App (App, fileSystemServiceClient), Handler) +import Foundation (App (App, fileSystemServiceClient, keyEncrptionKey), Handler) import Models.Inode (Inode (fileSystemId)) import Network.HTTP.Types (Status (Status)) +import UnliftIO.Resource +import Utils.HandlerUtils import Yesod.Core ( FileInfo, MonadHandler, @@ -40,11 +54,11 @@ import Yesod.Core sendResponseStatus, ) import Yesod.Core.Handler (sendResponseCreated) -import Utils.HandlerUtils +import Crypto.Init postUploadR :: Int -> Handler Value postUploadR parentId = do - App {fileSystemServiceClient = FileSystemServiceClient {createInode = createInode}} <- getYesod + App {fileSystemServiceClient = FileSystemServiceClient {createInode = createInode}, keyEncrptionKey = kek} <- getYesod authToken <- lookupBearerAuth case authToken of Nothing -> notAuthenticated @@ -64,9 +78,8 @@ postUploadR parentId = do Success createdInodes -> do case filter filterFiles createdInodes of [singleInode] -> do - let a = fileSystemId singleInode - fileDest <- liftIO $ storeFile singleInode - runConduitRes $ fileSource file .| fileDest + let alloc = makeAllocateResource kek singleInode + (_, _) <- allocate (alloc) (makeFreeResource file singleInode) return responseBody _ -> sendInternalError Error _ -> sendInternalError @@ -83,3 +96,24 @@ lookupUploadedInode mimeType = do lookupSingleFile :: [(Text.Text, FileInfo)] -> Maybe FileInfo lookupSingleFile [("file", file)] = Just file lookupSingleFile _ = Nothing + +-- this creates the encryptionKey by generating it +makeAllocateResource :: KeyEncryptionKey -> Inode -> IO (AES256, IV AES256) +makeAllocateResource kek inode = do + secretKey :: Key AES256 ByteString <- genSecretKey (undefined :: AES256) 32 + let Key keyBytes = secretKey + ivBytes <- genRandomIV (undefined :: AES256) + writeFile (getPathFromFileId (show $ fileSystemId inode) ++ ".key") (encryptWithKek kek keyBytes) + writeFile (getPathFromFileId (show $ fileSystemId inode) ++ ".iv") ivBytes + + return (initCipher secretKey, initIV ivBytes) + +-- this takes the encryption information and encrypts and moves the file after the response has been send +makeFreeResource :: FileInfo -> Inode -> (AES256, IV AES256) -> IO () +makeFreeResource fileInfo inode (cipher, iv) = do + fileDest <- storeFile inode + runConduitRes $ + fileSource fileInfo + .| encryptConduit cipher iv mempty + .| fileDest + diff --git a/src/Settings.hs b/src/Settings.hs index f53a798..7e75954 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -30,7 +30,8 @@ import Yesod.Default.Util data AppSettings = AppSettings { appProfile :: String, - fileSystemServiceSettings :: FileSystemServiceSettings + fileSystemServiceSettings :: FileSystemServiceSettings, + encryptionPassword :: String } deriving (Generic) diff --git a/src/Utils/ZipFile.hs b/src/Utils/ZipFile.hs index 8b023b2..0fc5699 100644 --- a/src/Utils/ZipFile.hs +++ b/src/Utils/ZipFile.hs @@ -8,8 +8,11 @@ import Codec.Archive.Zip.Conduit.Zip import ClassyPrelude.Conduit import Data.Time import FileStorage (retrieveFile, getInodeModifcationTime) +import Crypto.Cipher.AES +import Crypto.Cipher.Types +import Crypto.CryptoConduit (decryptConduit) -createZip :: [Models.Inode.Inode] -> FilePath -> IO () +createZip :: [(Models.Inode.Inode,(AES256, IV AES256))] -> FilePath -> IO () createZip inodes filename = do timeZone <- liftIO getCurrentTimeZone runConduitRes $ @@ -17,8 +20,8 @@ createZip inodes filename = do .| void (zipStream zipOptions) .| sinkFile filename -generateZipEntries :: (MonadIO m, MonadResource m) => [Models.Inode.Inode] -> TimeZone -> ConduitM () (ZipEntry, ZipData m) m () -generateZipEntries (currentInode : nextInodes) timeZone = do +generateZipEntries :: (MonadIO m, MonadResource m) => [(Models.Inode.Inode,(AES256, IV AES256))] -> TimeZone -> ConduitM () (ZipEntry, ZipData m) m () +generateZipEntries ((currentInode,(key,iv)) : nextInodes) timeZone = do let nameInZip = fromMaybe (Models.Inode.name currentInode) $ Models.Inode.path currentInode let size' = Models.Inode.size currentInode timeStamp <- liftIO $ getTimestampForInode currentInode @@ -30,7 +33,7 @@ generateZipEntries (currentInode : nextInodes) timeZone = do zipEntryExternalAttributes = Nothing } - yield (entry, ZipDataSource $retrieveFile currentInode) + yield (entry, ZipDataSource $retrieveFile currentInode .| decryptConduit key iv mempty ) generateZipEntries nextInodes timeZone return () generateZipEntries [] _ = return () From 63fecd58d2a1e4c41e531cd885aede2a436940ab Mon Sep 17 00:00:00 2001 From: qvalentin Date: Sun, 6 Feb 2022 17:39:19 +0100 Subject: [PATCH 09/35] Add decryption to preview --- src/Handler/Download.hs | 94 +++++++++++++++++++---------------------- src/Handler/Preview.hs | 18 ++++++-- src/Handler/Upload.hs | 6 ++- 3 files changed, 62 insertions(+), 56 deletions(-) diff --git a/src/Handler/Download.hs b/src/Handler/Download.hs index 1507f72..b5fc141 100644 --- a/src/Handler/Download.hs +++ b/src/Handler/Download.hs @@ -5,30 +5,48 @@ module Handler.Download where import ClassyPrelude - ( Bool (True), - Either (Right), - FilePath, - IO, - Int, - IsString (fromString), - Maybe (..), - Monad (return), - MonadIO (..), - Show (show), - String, - UTCTime, - Utf8 (decodeUtf8), - defaultTimeLocale, - fromMaybe, - maybe, - pack, - parseTimeM, - unpack, - void, - ($), - (++), - (<$>) - ) + ( Bool(True), + Either(Right), + FilePath, + IO, + Int, + IsString(fromString), + Maybe(..), + Monad(return), + MonadIO(..), + Show(show), + String, + UTCTime, + Utf8(decodeUtf8), + defaultTimeLocale, + fromMaybe, + maybe, + pack, + parseTimeM, + unpack, + void, + ($), + (++), + (<$>), + ($), + Monad(return), + Functor(fmap), + Show(show), + Traversable(mapM), + Monoid(mempty), + IO, + String, + MonadIO(liftIO), + fromMaybe, + maybe, + FilePath, + (<$>), + (++), + readFile, + tshow, + pack, + unpack, + Utf8(decodeUtf8) ) import ClassyPrelude.Yesod ( ConduitM, MonadHandler, @@ -67,27 +85,7 @@ import Utils.HandlerUtils (handleApiCall, lookupAuth) import Utils.ZipFile import Crypto.Cipher.AES import Crypto.Cipher.Types -import Crypto.KeyEncrptionKey (KeyEncryptionKey, decryptWithKek) -import ClassyPrelude - ( ($), - Monad(return), - Functor(fmap), - Show(show), - Traversable(mapM), - Monoid(mempty), - IO, - String, - MonadIO(liftIO), - fromMaybe, - maybe, - FilePath, - (<$>), - (++), - readFile, - tshow, - pack, - unpack, - Utf8(decodeUtf8) ) +import Crypto.KeyEncrptionKey (KeyEncryptionKey, decryptWithKek, getKeyForInode) import Crypto.Init import Crypto.Types (Key(Key)) import Crypto.CryptoConduit (decryptConduit) @@ -133,9 +131,3 @@ lookupRequiredInodeIds = do -getKeyForInode :: KeyEncryptionKey -> Inode -> IO (AES256, IV AES256) -getKeyForInode kek inode = do - key <- decryptWithKek kek <$> readFile (getPathFromFileId (show $ fileSystemId inode) ++ ".key") - iv <- readFile (getPathFromFileId (show $ fileSystemId inode) ++ ".iv") - - return (initCipher $ Key key, initIV iv) diff --git a/src/Handler/Preview.hs b/src/Handler/Preview.hs index eb3351f..3ac71f3 100644 --- a/src/Handler/Preview.hs +++ b/src/Handler/Preview.hs @@ -23,14 +23,26 @@ import Models.Inode import Utils.HandlerUtils import FileSystemServiceClient.FileSystemServiceClient hiding (mimeType) +import Crypto.KeyEncrptionKey +import ClassyPrelude + ( ($), + Show(show), + Monoid(mempty), + Int, + fromMaybe, + MonadIO(liftIO), + String ) +import Crypto.CryptoConduit getPreviewR :: Int -> String -> Handler TypedContent getPreviewR inodeId _ = do - App {fileSystemServiceClient = FileSystemServiceClient {getInodeInfo = getInodeInfo'}} <- getYesod + App {fileSystemServiceClient = FileSystemServiceClient {getInodeInfo = getInodeInfo'}, keyEncrptionKey = kek} <- getYesod bearerToken <- lookupAuth (responseBody', responseStatusCode, responseStatusMessage) <- liftIO $ getInodeInfo' bearerToken $ show inodeId inode <- handleApiCall responseBody' responseStatusCode responseStatusMessage + (key, iv) <- liftIO $ getKeyForInode kek inode respondSource (S8.pack $ fromMaybe "application/octet-stream" (mimeType inode)) $ - retrieveFile inode .| awaitForever sendChunkBS - + retrieveFile inode + .| decryptConduit key iv mempty + .| awaitForever sendChunkBS diff --git a/src/Handler/Upload.hs b/src/Handler/Upload.hs index ed7799a..1690ee5 100644 --- a/src/Handler/Upload.hs +++ b/src/Handler/Upload.hs @@ -26,7 +26,7 @@ import Data.Aeson fromJSON, object, ) -import Data.ByteArray +import Data.ByteArray hiding (take) import qualified Data.ByteString.Char8 as S8 import Data.CaseInsensitive (mk) import qualified Data.Text as Text @@ -55,6 +55,7 @@ import Yesod.Core ) import Yesod.Core.Handler (sendResponseCreated) import Crypto.Init +import System.Directory (createDirectoryIfMissing) postUploadR :: Int -> Handler Value postUploadR parentId = do @@ -79,7 +80,7 @@ postUploadR parentId = do case filter filterFiles createdInodes of [singleInode] -> do let alloc = makeAllocateResource kek singleInode - (_, _) <- allocate (alloc) (makeFreeResource file singleInode) + (_, _) <- allocate alloc (makeFreeResource file singleInode) return responseBody _ -> sendInternalError Error _ -> sendInternalError @@ -103,6 +104,7 @@ makeAllocateResource kek inode = do secretKey :: Key AES256 ByteString <- genSecretKey (undefined :: AES256) 32 let Key keyBytes = secretKey ivBytes <- genRandomIV (undefined :: AES256) + createDirectoryIfMissing True $ take 1 (show $ fileSystemId inode ) writeFile (getPathFromFileId (show $ fileSystemId inode) ++ ".key") (encryptWithKek kek keyBytes) writeFile (getPathFromFileId (show $ fileSystemId inode) ++ ".iv") ivBytes From d251d0a00e51439c878344d3f3ee50cef593d2f7 Mon Sep 17 00:00:00 2001 From: qvalentin Date: Wed, 9 Feb 2022 18:21:02 +0100 Subject: [PATCH 10/35] Store keys and ivs in seperate folder --- src/Crypto/KeyEncrptionKey.hs | 4 ++-- src/Handler/Upload.hs | 6 +++--- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/src/Crypto/KeyEncrptionKey.hs b/src/Crypto/KeyEncrptionKey.hs index 4be23d4..7e2b030 100644 --- a/src/Crypto/KeyEncrptionKey.hs +++ b/src/Crypto/KeyEncrptionKey.hs @@ -72,7 +72,7 @@ decryptWithKek r@KeyEncryptionKey {blockCipher = cipher, initialIV = iv} message getKeyForInode :: KeyEncryptionKey -> Inode -> IO (AES256, IV AES256) getKeyForInode kek inode = do - key <- decryptWithKek kek <$> readFile (getPathFromFileId (show $ fileSystemId inode) ++ ".key") - iv <- readFile (getPathFromFileId (show $ fileSystemId inode) ++ ".iv") + key <- decryptWithKek kek <$> readFile ("keys/" <> getPathFromFileId (show $ fileSystemId inode) ++ ".key") + iv <- readFile ("keys/" <> getPathFromFileId (show $ fileSystemId inode) ++ ".iv") return (initCipher $ Key key, initIV iv) diff --git a/src/Handler/Upload.hs b/src/Handler/Upload.hs index 1690ee5..b02cbbb 100644 --- a/src/Handler/Upload.hs +++ b/src/Handler/Upload.hs @@ -104,9 +104,9 @@ makeAllocateResource kek inode = do secretKey :: Key AES256 ByteString <- genSecretKey (undefined :: AES256) 32 let Key keyBytes = secretKey ivBytes <- genRandomIV (undefined :: AES256) - createDirectoryIfMissing True $ take 1 (show $ fileSystemId inode ) - writeFile (getPathFromFileId (show $ fileSystemId inode) ++ ".key") (encryptWithKek kek keyBytes) - writeFile (getPathFromFileId (show $ fileSystemId inode) ++ ".iv") ivBytes + createDirectoryIfMissing True $ "keys/" <> take 1 (show $ fileSystemId inode ) + writeFile ("keys/" <> getPathFromFileId (show $ fileSystemId inode) ++ ".key") (encryptWithKek kek keyBytes) + writeFile ("keys/" <> getPathFromFileId (show $ fileSystemId inode) ++ ".iv") ivBytes return (initCipher secretKey, initIV ivBytes) From f3bca44051284f96873f5bba097bc8602ab1735c Mon Sep 17 00:00:00 2001 From: qvalentin Date: Fri, 11 Feb 2022 16:18:17 +0100 Subject: [PATCH 11/35] (Deps) update to newer stack resolver --- package.yaml | 16 +++++++++++++--- stack.yaml | 6 +++--- stack.yaml.lock | 17 ++++++++++++----- 3 files changed, 28 insertions(+), 11 deletions(-) diff --git a/package.yaml b/package.yaml index bfba80e..e93ce67 100644 --- a/package.yaml +++ b/package.yaml @@ -5,9 +5,9 @@ dependencies: - base - yesod - yesod-core -- classy-prelude >=1.5 && <1.6 -- classy-prelude-conduit >=1.5 && <1.6 -- classy-prelude-yesod >=1.5 && <1.6 +- classy-prelude +- classy-prelude-conduit +- classy-prelude-yesod - http-types - bytestring - aeson @@ -36,6 +36,13 @@ dependencies: # defined below is just a thin wrapper. library: source-dirs: src + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + - -fwrite-ide-info + - -hiedir=.hie + # Runnable executable for our application executables: @@ -46,6 +53,9 @@ executables: - -threaded - -rtsopts - -with-rtsopts=-N + - -fwrite-ide-info + - -hiedir=.hie + dependencies: - FileHandlerYesod diff --git a/stack.yaml b/stack.yaml index 5560d7d..439c254 100644 --- a/stack.yaml +++ b/stack.yaml @@ -18,7 +18,7 @@ # resolver: ./custom-snapshot.yaml # resolver: https://example.com/snapshots/2018-01-01.yaml resolver: - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/31.yaml + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/24.yaml # User packages to be built. @@ -41,8 +41,8 @@ packages: # - git: https://github.com/commercialhaskell/stack.git # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a # -# extra-deps: [] - +extra-deps: +- classy-prelude-yesod-1.5.0@sha256:8f7e183bdfd6d2ea9674284c4f285294ab086aff60d9be4e5d7d2f3c1a2b05b7,1330 # Override default flag values for local packages and extra-deps # flags: {} diff --git a/stack.yaml.lock b/stack.yaml.lock index 49011c7..fc68686 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -3,11 +3,18 @@ # For more information, please see the documentation at: # https://docs.haskellstack.org/en/stable/lock_files -packages: [] +packages: +- completed: + hackage: classy-prelude-yesod-1.5.0@sha256:8f7e183bdfd6d2ea9674284c4f285294ab086aff60d9be4e5d7d2f3c1a2b05b7,1330 + pantry-tree: + sha256: ae84d4cc0e1daf985db6cdcf2ac92319531b8e60f547183cc46480d00aafbe20 + size: 330 + original: + hackage: classy-prelude-yesod-1.5.0@sha256:8f7e183bdfd6d2ea9674284c4f285294ab086aff60d9be4e5d7d2f3c1a2b05b7,1330 snapshots: - completed: - sha256: 637fb77049b25560622a224845b7acfe81a09fdb6a96a3c75997a10b651667f6 - size: 534126 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/31.yaml + sha256: 06d844ba51e49907bd29cb58b4a5f86ee7587a4cd7e6cf395eeec16cba619ce8 + size: 587821 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/24.yaml original: - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/16/31.yaml + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/24.yaml From 7281ed8d5e7b44d4a04573aae18c0ece4edf5801 Mon Sep 17 00:00:00 2001 From: qvalentin Date: Fri, 11 Feb 2022 16:20:08 +0100 Subject: [PATCH 12/35] gitigonre --- .gitignore | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/.gitignore b/.gitignore index 6d03cad..5cdb5b3 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,5 @@ *.aux +kek.iv *.chi *.chs.h *.dyn_hi @@ -33,3 +34,14 @@ dist-* static/combined/ static/tmp/ yesod-devel/ +.hie +1 +2 +3 +4 +5 +client_session_key.aes +keys +mprofile_*.dat +stan.html + From 470ab08759360efa96301d98203f7384f047cb94 Mon Sep 17 00:00:00 2001 From: qvalentin Date: Fri, 25 Mar 2022 13:21:57 +0100 Subject: [PATCH 13/35] Adapt Upload to new api --- package.yaml | 43 ++++++-------- routes.yesodroutes | 2 +- src/Application.hs | 55 +++++++++++++---- src/Crypto/CryptoConduit.hs | 1 + src/FileStorage.hs | 4 +- .../FileSystemServiceClient.hs | 18 +++--- src/Foundation.hs | 2 +- src/Handler/Upload.hs | 59 +++++++++---------- src/Models/Inode.hs | 14 ++--- src/Models/Path.hs | 23 ++++++++ src/Models/User.hs | 16 ++++- src/Utils/HandlerUtils.hs | 6 +- 12 files changed, 152 insertions(+), 91 deletions(-) create mode 100644 src/Models/Path.hs diff --git a/package.yaml b/package.yaml index e93ce67..69a3fd7 100644 --- a/package.yaml +++ b/package.yaml @@ -2,33 +2,34 @@ name: FileHandlerYesod version: "0.1.0" dependencies: +- aeson - base -- yesod -- yesod-core +- bytestring +- case-insensitive - classy-prelude - classy-prelude-conduit - classy-prelude-yesod +- cryptonite +- directory +- file-embed +- filepath - http-types -- bytestring -- aeson +- memory +- mtl +- req +- resourcet +- temporary +- text +- time - wai - wai-extra +- wai-cors - warp -- text -- req -- zip -- temporary -- case-insensitive -- resourcet -- mtl -- directory -- filepath - yaml -- file-embed +- yesod +- yesod-core +- zip - zip-stream -- time -- cryptonite -- memory @@ -36,12 +37,6 @@ dependencies: # defined below is just a thin wrapper. library: source-dirs: src - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - - -fwrite-ide-info - - -hiedir=.hie # Runnable executable for our application @@ -53,8 +48,6 @@ executables: - -threaded - -rtsopts - -with-rtsopts=-N - - -fwrite-ide-info - - -hiedir=.hie dependencies: - FileHandlerYesod diff --git a/routes.yesodroutes b/routes.yesodroutes index 77d3f68..16f10e8 100644 --- a/routes.yesodroutes +++ b/routes.yesodroutes @@ -1,6 +1,6 @@ / HomeR GET /data/download DownloadR GET -/data/upload/#Int UploadR POST +/data/upload UploadR POST /data/delete/#Int DeleteR DELETE /data/preview/#Int/#String PreviewR GET /data/health HealthR GET diff --git a/src/Application.hs b/src/Application.hs index 61cb6e7..b150530 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -5,22 +5,42 @@ module Application where import ClassyPrelude + ( ($), + Monad(return), + Num((*)), + Bool(False, True), + Maybe(Just, Nothing), + IO, + const ) import Crypto.KeyEncrptionKey (createKeyEncrptionKey, getOrCreateKekIV) -import Data.Yaml.Config +import Data.Yaml.Config ( loadYamlSettingsArgs, useEnv ) import FileSystemServiceClient.FileSystemServiceClient (makeFileSystemServiceClient) import Foundation -import Handler.Delete -import Handler.Download -import Handler.Error -import Handler.Health -import Handler.Home -import Handler.Preview -import Handler.Upload + ( Route(ErrorR, HomeR, DownloadR, UploadR, DeleteR, PreviewR, + HealthR), + App(..), + resourcesApp ) +import Handler.Delete ( deleteDeleteR ) +import Handler.Download ( getDownloadR ) +import Handler.Error ( getErrorR ) +import Handler.Health ( getHealthR ) +import Handler.Home ( getHomeR ) +import Handler.Preview ( getPreviewR ) +import Handler.Upload ( postUploadR ) +import Network.Wai () +import Network.Wai.Handler.Warp ( run ) +import Network.Wai.Middleware.Cors + ( cors, + CorsResourcePolicy(CorsResourcePolicy, corsOrigins, corsMethods, + corsRequestHeaders, corsExposedHeaders, corsMaxAge, corsVaryOrigin, + corsRequireOrigin, corsIgnoreFailures) ) +import Network.Wai.Parse () +import Network.Wai.Middleware.Cors () import Settings ( AppSettings (encryptionPassword, fileSystemServiceSettings), configSettingsYmlValue, ) -import Yesod.Core +import Yesod.Core ( toWaiApp, mkYesodDispatch ) mkYesodDispatch "App" resourcesApp @@ -50,4 +70,19 @@ appMain = do app <- makeFoundation settings - warp 5000 app + application <- toWaiApp app + + run 5000 $ cors (const devCorsPolicy) application + +devCorsPolicy = + Just + CorsResourcePolicy + { corsOrigins = Just (["http://localhost:3000"],True), + corsMethods = ["GET", "POST", "DELETE"], + corsRequestHeaders = ["Authorization", "content-type", "X-FF-IDS", "X-FF-ID", "X-FF-NAME", "X-FF-PATH", "X-FF-SIZE","X-FF-PARENT-PATH","X-FF-RELATIVE-PATH","X-FF-PARENT-PATH"], + corsExposedHeaders = Just ["Content-Disposition"], + corsMaxAge = Just $ 60 * 60 * 24, -- one day + corsVaryOrigin = False, + corsRequireOrigin = False, + corsIgnoreFailures = False + } diff --git a/src/Crypto/CryptoConduit.hs b/src/Crypto/CryptoConduit.hs index 50b543f..7569fa2 100644 --- a/src/Crypto/CryptoConduit.hs +++ b/src/Crypto/CryptoConduit.hs @@ -42,6 +42,7 @@ import ClassyPrelude.Conduit await, yield ) import Crypto.Cipher.Types + ( BlockCipher(blockSize, cbcEncrypt, cbcDecrypt), IV, makeIV ) import Crypto.Data.Padding encryptConduit :: (BlockCipher c, Monad m) => c -> IV c -> ByteString -> ConduitT ByteString ByteString m () diff --git a/src/FileStorage.hs b/src/FileStorage.hs index 5a880d4..bc62c03 100644 --- a/src/FileStorage.hs +++ b/src/FileStorage.hs @@ -33,6 +33,6 @@ getInodeModifcationTime inode = do filterFiles :: Inode -> Bool -filterFiles file = case filesystemType file of - "FOLDER" -> False +filterFiles file = case mimeType file of + Nothing -> False _ -> True diff --git a/src/FileSystemServiceClient/FileSystemServiceClient.hs b/src/FileSystemServiceClient/FileSystemServiceClient.hs index acb6e7f..a1b4a31 100644 --- a/src/FileSystemServiceClient/FileSystemServiceClient.hs +++ b/src/FileSystemServiceClient/FileSystemServiceClient.hs @@ -35,19 +35,21 @@ import Network.HTTP.Req import qualified Network.HTTP.Req as Req import Settings import ClassyPrelude hiding (pack, encodeUtf8) +import Models.Path (Path) data FileSystemServiceClient = FileSystemServiceClient { deleteInode :: Text -> String -> IO (Value, Int, ByteString), - createInode :: Text -> UploadedInode -> String -> IO (Value, Int, ByteString), + createInode :: Text -> UploadedInode -> IO (Value, Int, ByteString), getInodeInfo ::Text -> String -> IO (Value, Int, ByteString), getInodeContent :: Text -> String -> IO (Value, Int, ByteString, Maybe ByteString) } data UploadedInode = UploadedInode - { name :: String, - path :: String, - mimeType :: String, - size :: String + { + parentPath :: Path, + relativePath :: Path, + size :: Integer, + mimeType :: String } deriving (Show, Generic) @@ -78,13 +80,13 @@ makeDeleteInode r@FileSystemServiceSettings {url = url, port = port} authorizati oAuth2Bearer' token = header "Authorization" ("Bearer " <> token) -makeCreateInode :: FileSystemServiceSettings -> Text -> UploadedInode -> String -> IO (Value, Int, ByteString) -makeCreateInode r@FileSystemServiceSettings {url = url, port = port} authorization uploadedInode fileId = runReq (defaultHttpConfig {httpConfigCheckResponse = httpConfigDontCheckResponse}) $ do +makeCreateInode :: FileSystemServiceSettings -> Text -> UploadedInode -> IO (Value, Int, ByteString) +makeCreateInode r@FileSystemServiceSettings {url = url, port = port} authorization uploadedInode = runReq (defaultHttpConfig {httpConfigCheckResponse = httpConfigDontCheckResponse}) $ do r <- req POST -- method --(http (DataText.pack restUrl) /: "t/os3vu-1615111052/post") - (http (pack url) /: "v1" /: "filesystem" /: pack fileId /: "upload") + (http (pack url) /: "api" /: "filesystem" /: "upload") (ReqBodyJson uploadedInode) -- use built-in options or add your own jsonResponse (oAuth2Bearer' (encodeUtf8 authorization) <> Req.port port) -- parentID not in Headers diff --git a/src/Foundation.hs b/src/Foundation.hs index 77dda46..8ee7b64 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -31,6 +31,6 @@ data App = App mkYesodData "App" $(parseRoutesFile "routes.yesodroutes") instance Yesod App where - maximumContentLength _ (Just (UploadR _)) = Nothing + maximumContentLength _ (Just (UploadR)) = Nothing maximumContentLength _ _ = Just (2 * 1024 * 1024) -- 2 megabytes fileUpload _ _ = FileUploadDisk tempFileBackEnd diff --git a/src/Handler/Upload.hs b/src/Handler/Upload.hs index b02cbbb..dfd3b0c 100644 --- a/src/Handler/Upload.hs +++ b/src/Handler/Upload.hs @@ -11,7 +11,7 @@ import ClassyPrelude.Yesod ( ConduitT, FileInfo (fileContentType), runConduitRes, - (.|), + (.|), defaultMakeLogger, Response (responseBody) ) import Crypto.Cipher.AES import Crypto.Cipher.Types (BlockCipher, IV, cipherInit, makeIV) @@ -56,43 +56,38 @@ import Yesod.Core import Yesod.Core.Handler (sendResponseCreated) import Crypto.Init import System.Directory (createDirectoryIfMissing) +import Yesod.Core.Types (loggerPutStr) +import Prelude (read) +import Models.Path (Path(Path)) -postUploadR :: Int -> Handler Value -postUploadR parentId = do +postUploadR :: Handler Value +postUploadR = do App {fileSystemServiceClient = FileSystemServiceClient {createInode = createInode}, keyEncrptionKey = kek} <- getYesod - authToken <- lookupBearerAuth - case authToken of - Nothing -> notAuthenticated - Just bearerToken -> do - (_params, files) <- runRequestBody - case lookupSingleFile files of - Nothing -> invalidArgs ["Missing required File."] - Just file -> do - inodeToCreate <- lookupUploadedInode $ Just (Text.unpack $ fileContentType file) - case inodeToCreate of - Nothing -> invalidArgs ["Missing required Header."] - Just inode -> do - (responseBody, responseStatusCode, responseStatusMessage) <- liftIO $ createInode bearerToken inode (show parentId) - case responseStatusCode of - 201 -> do - case fromJSON responseBody of - Success createdInodes -> do - case filter filterFiles createdInodes of - [singleInode] -> do - let alloc = makeAllocateResource kek singleInode - (_, _) <- allocate alloc (makeFreeResource file singleInode) - return responseBody - _ -> sendInternalError - Error _ -> sendInternalError - _ -> sendResponseStatus (Status responseStatusCode responseStatusMessage) responseBody + authToken <- lookupAuth + (_params, files) <- runRequestBody + case lookupSingleFile files of + Nothing -> invalidArgs ["Missing required File."] + Just file -> do + inodeToCreate <- lookupUploadedInode $ Just (Text.unpack $ fileContentType file) + case inodeToCreate of + Nothing -> invalidArgs ["Missing required Header."] + Just inode -> do + (responseBody, responseStatusCode, responseStatusMessage) <- liftIO $ createInode authToken inode + liftIO $ print $ show responseBody + createdInodes <- handleApiCall responseBody responseStatusCode responseStatusMessage + case filter filterFiles createdInodes of + [singleInode] -> do + let alloc = makeAllocateResource kek singleInode + (_, _) <- allocate alloc (makeFreeResource file singleInode) + return responseBody + _ -> sendInternalError lookupUploadedInode :: MonadHandler m => Maybe String -> m (Maybe UploadedInode) lookupUploadedInode mimeType = do - name <- lookupHeader $ Data.CaseInsensitive.mk "X-FF-NAME" - path <- lookupHeader $ Data.CaseInsensitive.mk "X-FF-PATH" + relativePath <- lookupHeader $ Data.CaseInsensitive.mk "X-FF-RELATIVE-PATH" + parentPath <- lookupHeader $ Data.CaseInsensitive.mk "X-FF-PARENT-PATH" size <- lookupHeader $ Data.CaseInsensitive.mk "X-FF-SIZE" - - return $ UploadedInode <$> (S8.unpack <$> name) <*> (S8.unpack <$> path) <*> mimeType <*> (S8.unpack <$> size) + return $ UploadedInode <$> (Path . S8.unpack <$> parentPath) <*> (Path . S8.unpack <$> relativePath) <*> (read . S8.unpack <$> size) <*> mimeType lookupSingleFile :: [(Text.Text, FileInfo)] -> Maybe FileInfo lookupSingleFile [("file", file)] = Just file diff --git a/src/Models/Inode.hs b/src/Models/Inode.hs index 0135241..2a6f650 100644 --- a/src/Models/Inode.hs +++ b/src/Models/Inode.hs @@ -5,24 +5,22 @@ module Models.Inode where import ClassyPrelude import Data.Aeson import Models.User +import Models.Path (Path) data Inode = Inode - { fileSystemId :: !Int, + { fileSystemId :: String, name :: String, path :: Maybe String, + mimeType :: Maybe String, size :: Int, - owner :: User, - lastUpdatedBy :: User, lastUpdated :: Int, - mimeType :: Maybe String, - filesystemType :: String, - shared :: Bool + lastUpdatedBy :: User } deriving (Show, Generic) typeFieldRename :: String -> String -typeFieldRename "filesystemType" = "type" -typeFieldRename "type" = "filesystemType" +typeFieldRename "fileSystemId" = "id" +typeFieldRename "id" = "fileSystemId" typeFieldRename name = name instance FromJSON Inode where diff --git a/src/Models/Path.hs b/src/Models/Path.hs new file mode 100644 index 0000000..1da6887 --- /dev/null +++ b/src/Models/Path.hs @@ -0,0 +1,23 @@ +-- | + +{-# LANGUAGE DeriveGeneric #-} +module Models.Path where +import ClassyPrelude +import ClassyPrelude.Yesod + + + +newtype Path = Path { + path :: String + } + deriving (Show, Generic) + + + +instance ToJSON Path where + toJSON (Path path) = toJSON $ addLeadingSlash path + +addLeadingSlash :: String -> String +addLeadingSlash path + | "/" `isPrefixOf` path = path + | otherwise = "/" <> path diff --git a/src/Models/User.hs b/src/Models/User.hs index ff7c366..406b8d4 100644 --- a/src/Models/User.hs +++ b/src/Models/User.hs @@ -8,10 +8,22 @@ import Data.Aeson data User = User { userId :: Int, username :: String, - groups :: [String] + privileges :: String } deriving (Show, Generic) -instance FromJSON User instance ToJSON User + +userIdFieldRename :: String -> String +userIdFieldRename "userId" = "id" +userIdFieldRename "id" = "userId" +userIdFieldRename name = name + +instance FromJSON User where + parseJSON = + genericParseJSON + defaultOptions + { fieldLabelModifier = userIdFieldRename, + omitNothingFields = True + } diff --git a/src/Utils/HandlerUtils.hs b/src/Utils/HandlerUtils.hs index 2574d0a..9490714 100644 --- a/src/Utils/HandlerUtils.hs +++ b/src/Utils/HandlerUtils.hs @@ -21,7 +21,7 @@ import ClassyPrelude (.), elem, pack, - Utf8(decodeUtf8) ) + Utf8(decodeUtf8), MonadIO (liftIO), print, putStr, putStrLn ) import Data.Aeson import Foundation import Models.RestApiStatus @@ -48,7 +48,9 @@ handleApiCall body statusCode statusMessage case fromJSON body of Success value -> return value - Error _ -> sendInternalError + Error e -> do + liftIO $ print e + sendInternalError | 400 <= statusCode && statusCode < 500 = sendErrorOrRedirect (Status statusCode statusMessage) body --sendResponseStatus (Status statusCode statusMessage) body | otherwise = sendInternalError From 6c9d358fe5c0c3464c8c9bc6fc17ffb20f1b1f1b Mon Sep 17 00:00:00 2001 From: qvalentin Date: Fri, 25 Mar 2022 19:06:12 +0100 Subject: [PATCH 14/35] download for multiple files in same folder --- routes.yesodroutes | 6 +- .../FileSystemServiceClient.hs | 32 ++-- src/Handler/Delete.hs | 53 +++--- src/Handler/Download.hs | 155 ++++++++++-------- src/Handler/Preview.hs | 43 +++-- src/Models/Path.hs | 24 ++- src/Utils/HandlerUtils.hs | 8 +- 7 files changed, 190 insertions(+), 131 deletions(-) diff --git a/routes.yesodroutes b/routes.yesodroutes index 16f10e8..243de41 100644 --- a/routes.yesodroutes +++ b/routes.yesodroutes @@ -1,7 +1,7 @@ / HomeR GET -/data/download DownloadR GET +/data/download/*[Text] DownloadR GET /data/upload UploadR POST -/data/delete/#Int DeleteR DELETE -/data/preview/#Int/#String PreviewR GET +/data/delete/+[Text] DeleteR DELETE +/data/preview/*[Text] PreviewR GET /data/health HealthR GET /error ErrorR GET diff --git a/src/FileSystemServiceClient/FileSystemServiceClient.hs b/src/FileSystemServiceClient/FileSystemServiceClient.hs index a1b4a31..b3c3f0f 100644 --- a/src/FileSystemServiceClient/FileSystemServiceClient.hs +++ b/src/FileSystemServiceClient/FileSystemServiceClient.hs @@ -34,14 +34,15 @@ import Network.HTTP.Req ReqBodyJson(ReqBodyJson) ) import qualified Network.HTTP.Req as Req import Settings -import ClassyPrelude hiding (pack, encodeUtf8) -import Models.Path (Path) +import ClassyPrelude hiding (intercalate, pack, encodeUtf8) +import Models.Path (Path, fromMultiPiece, toByteString) +import qualified Data.ByteString as S8 data FileSystemServiceClient = FileSystemServiceClient - { deleteInode :: Text -> String -> IO (Value, Int, ByteString), + { deleteInode :: Text -> [Text] -> IO (Value, Int, ByteString), createInode :: Text -> UploadedInode -> IO (Value, Int, ByteString), getInodeInfo ::Text -> String -> IO (Value, Int, ByteString), - getInodeContent :: Text -> String -> IO (Value, Int, ByteString, Maybe ByteString) + getInodeContent :: Text -> Path -> IO (Value, Int, ByteString) } data UploadedInode = UploadedInode @@ -67,15 +68,16 @@ makeFileSystemServiceClient fileSystemServiceSettings = getInodeContent = makeGetInodeContent fileSystemServiceSettings } -makeDeleteInode :: FileSystemServiceSettings -> Text -> String -> IO (Value, Int, ByteString) -makeDeleteInode r@FileSystemServiceSettings {url = url, port = port} authorization fileId = runReq (defaultHttpConfig {httpConfigCheckResponse = httpConfigDontCheckResponse}) $ do +makeDeleteInode :: FileSystemServiceSettings -> Text -> [Text] -> IO (Value, Int, ByteString) +makeDeleteInode r@FileSystemServiceSettings {url = url, port = port} authorization path = runReq (defaultHttpConfig {httpConfigCheckResponse = httpConfigDontCheckResponse}) $ do r <- req DELETE - (http (pack url) /: "v1" /: "filesystem" /: pack fileId /: "delete") + (http (pack url) /: "api" /: "filesystem" /: "delete") NoReqBody jsonResponse - (oAuth2Bearer' (encodeUtf8 authorization) <> Req.port port) -- parentID not in Headers + (oAuth2Bearer' (encodeUtf8 authorization) <> Req.port port + <> header "X-FF-PATH" (toByteString $ fromMultiPiece path)) return (responseBody r, responseStatusCode r, responseStatusMessage r) oAuth2Bearer' token = header "Authorization" ("Bearer " <> token) @@ -105,19 +107,17 @@ makeGetInodeInfo r@FileSystemServiceSettings {url = url, port = port} authorizat -- mempty -- query params, headers, explicit port number, etc. return (responseBody r, responseStatusCode r, responseStatusMessage r) -makeGetInodeContent :: FileSystemServiceSettings -> Text -> String -> IO (Value, Int, ByteString, Maybe ByteString) -makeGetInodeContent r@FileSystemServiceSettings {url = url, port = port} authorization ids = runReq (defaultHttpConfig {httpConfigCheckResponse = httpConfigDontCheckResponse}) $ do +makeGetInodeContent :: FileSystemServiceSettings -> Text -> Path -> IO (Value, Int, ByteString) +makeGetInodeContent r@FileSystemServiceSettings {url = url, port = port} authorization path = runReq (defaultHttpConfig {httpConfigCheckResponse = httpConfigDontCheckResponse}) $ do r <- req GET -- method - (http (pack url) /: "v1" /: "filesystem" /: "download") -- safe by construction URL + (http (pack url) /: "api" /: "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 jsonResponse -- specify how to interpret response (oAuth2Bearer' (encodeUtf8 authorization) - <> Req.port port - <> header "X-FF-IDS" (fromString ids) - <> header "Cookie" ("token=" <> encodeUtf8 authorization) - <> (=:) "ids" ids ) + <> Req.port port + <> header "X-FF-PATH" (toByteString path)) -- mempty -- query params, headers, explicit port number, etc. - return (responseBody r, responseStatusCode r, responseStatusMessage r, responseHeader r "X-FF-NAME") + return (responseBody r, responseStatusCode r, responseStatusMessage r) diff --git a/src/Handler/Delete.hs b/src/Handler/Delete.hs index 1c04727..317dc70 100644 --- a/src/Handler/Delete.hs +++ b/src/Handler/Delete.hs @@ -1,45 +1,36 @@ --- | {-# LANGUAGE OverloadedStrings #-} -module Handler.Delete where -import Foundation -import Yesod.Core +-- | +module Handler.Delete where -import ClassyPrelude hiding (filter, Handler) -import qualified Data.Text as DataText +import ClassyPrelude hiding (Handler, filter) import Data.Aeson import Data.Maybe (fromMaybe) +import qualified Data.Text as DataText +import FileStorage (filterFiles, getPathFromFileId) +import FileSystemServiceClient.FileSystemServiceClient +import Foundation import Models.Inode import Network.HTTP.Req -import System.Directory -import FileSystemServiceClient.FileSystemServiceClient import Network.HTTP.Types +import System.Directory import Utils.HandlerUtils -import FileStorage (filterFiles, getPathFromFileId) +import Yesod.Core import Prelude (filter) - - -serverPort = port 80 - -deleteDeleteR :: Int -> Handler Value -deleteDeleteR inodeId = do - App{fileSystemServiceClient = FileSystemServiceClient{deleteInode= deleteInode}} <- getYesod - authToken <- lookupBearerAuth - case authToken of - Nothing -> notAuthenticated - Just bearerToken -> do - (responseBody, responseStatusCode, responseStatusMessage) <- liftIO $ deleteInode bearerToken (show inodeId) - case responseStatusCode of - 200 -> do - case fromJSON responseBody of - Success inodes -> do - liftIO $ mapM_ deleteFile (filter filterFiles inodes) -- Todo: check if file exists - return responseBody - Error _ -> sendInternalError - _ -> sendResponseStatus (Status responseStatusCode responseStatusMessage) responseBody - - +deleteDeleteR :: [Text] -> Handler Value +deleteDeleteR path = do + App {fileSystemServiceClient = FileSystemServiceClient {deleteInode = deleteInode}} <- getYesod + authToken <- lookupAuth + (responseBody, responseStatusCode, responseStatusMessage) <- liftIO $ deleteInode authToken path + case responseStatusCode of + 200 -> do + case fromJSON responseBody of + Success inodes -> do + liftIO $ mapM_ deleteFile (filter filterFiles inodes) -- Todo: check if file exists + return responseBody + Error _ -> sendInternalError + _ -> sendResponseStatus (Status responseStatusCode responseStatusMessage) responseBody deleteFile :: Inode -> IO () deleteFile file = removeFile $ getPathFromFileId (show $ fileSystemId file) diff --git a/src/Handler/Download.hs b/src/Handler/Download.hs index b5fc141..ac06691 100644 --- a/src/Handler/Download.hs +++ b/src/Handler/Download.hs @@ -1,57 +1,60 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Use join" #-} module Handler.Download where import ClassyPrelude - ( Bool(True), - Either(Right), - FilePath, - IO, - Int, - IsString(fromString), - Maybe(..), - Monad(return), - MonadIO(..), - Show(show), - String, - UTCTime, - Utf8(decodeUtf8), - defaultTimeLocale, - fromMaybe, - maybe, - pack, - parseTimeM, - unpack, - void, - ($), - (++), - (<$>), - ($), - Monad(return), - Functor(fmap), - Show(show), - Traversable(mapM), - Monoid(mempty), - IO, - String, - MonadIO(liftIO), - fromMaybe, - maybe, - FilePath, - (<$>), - (++), - readFile, - tshow, - pack, - unpack, - Utf8(decodeUtf8) ) + ( Bool (True), + ByteString, + Either (Right), + FilePath, + Functor (fmap), + IO, + Int, + IsMap (lookup), + IsString (fromString), + Maybe (..), + Monad (return), + MonadIO (..), + Monoid (mempty), + Show (show), + String, + Text, + Traversable (mapM), + UTCTime, + Utf8 (decodeUtf8), + concat, + concatMap, + defaultTimeLocale, + fromMaybe, + id, + join, + map, + maybe, + pack, + parseTimeM, + pure, + readFile, + tshow, + unpack, + void, + ($), + (++), + (.), + (<$>), + (<>), + (=<<), + ) import ClassyPrelude.Yesod ( ConduitM, MonadHandler, MonadResource, TypedContent, + Value, addHeader, awaitForever, getYesod, @@ -65,39 +68,60 @@ import ClassyPrelude.Yesod yield, (.|), ) +import Crypto.Cipher.AES +import Crypto.Cipher.Types +import Crypto.CryptoConduit (decryptConduit) +import Crypto.Init +import Crypto.KeyEncrptionKey (KeyEncryptionKey, decryptWithKek, getKeyForInode) +import Crypto.Types (Key (Key)) import qualified Data.ByteString.Char8 as S8 -import FileStorage (getInodeModifcationTime, retrieveFile, getPathFromFileId) +import Data.Text (splitAt, splitOn) +import FileStorage (getInodeModifcationTime, getPathFromFileId, retrieveFile) import FileSystemServiceClient.FileSystemServiceClient ( FileSystemServiceClient ( FileSystemServiceClient, getInodeContent ), + UploadedInode (parentPath), ) import Foundation (App (App, fileSystemServiceClient, keyEncrptionKey), Handler) import Models.Inode - ( Inode (lastUpdated, mimeType, name, path, size), fileSystemId + ( Inode (lastUpdated, mimeType, name, path, size), + fileSystemId, ) +import Models.Path (Path, fromMultiPiece) +import Network.HTTP.Req (responseStatusMessage) import qualified Network.HTTP.Types as HttpTypes import System.Directory (doesDirectoryExist, removeFile) import System.IO.Temp (emptySystemTempFile) import UnliftIO.Resource (allocate) import Utils.HandlerUtils (handleApiCall, lookupAuth) import Utils.ZipFile -import Crypto.Cipher.AES -import Crypto.Cipher.Types -import Crypto.KeyEncrptionKey (KeyEncryptionKey, decryptWithKek, getKeyForInode) -import Crypto.Init -import Crypto.Types (Key(Key)) -import Crypto.CryptoConduit (decryptConduit) +import Yesod.Routes.TH.Types (flatten) -getDownloadR :: Handler TypedContent -getDownloadR = do +getDownloadR :: [Text] -> Handler TypedContent +getDownloadR path = do App {fileSystemServiceClient = FileSystemServiceClient {getInodeContent = getInodeContent}, keyEncrptionKey = kek} <- getYesod bearerToken <- lookupAuth - inodeIds <- lookupRequiredInodeIds - (responseBody, responseStatusCode, responseStatusMessage, maybeFilename) <- liftIO $ getInodeContent bearerToken inodeIds - inodes <- handleApiCall responseBody responseStatusCode responseStatusMessage + paths <- lookupPaths path + + apiResponses <- + liftIO $ + mapM + ( \path -> do + (responseBody, responseStatusCode, responseStatusMessage) <- getInodeContent bearerToken path + return (responseBody, responseStatusCode, responseStatusMessage) + ) + paths + + inodes <- concat <$> + mapM + ( \(responseBody, responseStatusCode, responseStatusMessage) -> do + handleApiCall responseBody responseStatusCode responseStatusMessage + ) + apiResponses + case inodes of [singleInode] -> do addHeader "Content-Disposition" $ pack ("attachment; filename=\"" ++ Models.Inode.name singleInode ++ "\"") @@ -105,15 +129,22 @@ getDownloadR = do (key, iv) <- liftIO $ getKeyForInode kek singleInode respondSource (S8.pack $ fromMaybe "application/octet-stream" (mimeType singleInode)) $ retrieveFile singleInode - .| decryptConduit key iv mempty - .| awaitForever sendChunkBS + .| decryptConduit key iv mempty + .| awaitForever sendChunkBS multipleInodes -> do - let archiveName = fromMaybe "Files" maybeFilename + let archiveName = fromMaybe "Files" Nothing addHeader "Content-Disposition" ("attachment; filename=\"" ++ decodeUtf8 archiveName ++ ".zip" ++ "\"") (_, tempFile) <- allocate (makeAllocateResource kek multipleInodes) freeResource sendFile "application/zip" tempFile -makeAllocateResource :: KeyEncryptionKey -> [Models.Inode.Inode] -> IO FilePath +lookupPaths :: MonadHandler m => [Text] -> m [Path] +lookupPaths parentPath = do + maybeChildenParam <- lookupGetParam "children" + case splitOn "," <$> maybeChildenParam of + Just inodeNames -> pure $ map (\name -> fromMultiPiece $ parentPath <> [name]) inodeNames + Nothing -> pure [fromMultiPiece parentPath] + +makeAllocateResource :: KeyEncryptionKey -> [Models.Inode.Inode] -> IO FilePath makeAllocateResource kek inodes = do path <- emptySystemTempFile "FileFighterFileHandler.zip" inodesWithKeys <- mapM (\inode -> fmap (inode,) (getKeyForInode kek inode)) inodes @@ -123,11 +154,7 @@ makeAllocateResource kek inodes = do freeResource :: FilePath -> IO () freeResource = removeFile - lookupRequiredInodeIds :: MonadHandler m => m String lookupRequiredInodeIds = do maybeIds <- lookupGetParam "ids" maybe (invalidArgs ["Missing ids query parameter."]) return $ unpack <$> maybeIds - - - diff --git a/src/Handler/Preview.hs b/src/Handler/Preview.hs index 3ac71f3..9844bbf 100644 --- a/src/Handler/Preview.hs +++ b/src/Handler/Preview.hs @@ -1,4 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} module Handler.Preview where @@ -14,16 +15,17 @@ import ClassyPrelude.Yesod awaitForever, respondSource, sendChunkBS, - TypedContent ) + TypedContent, badRequest400, status400, ToJSON (toJSON) ) import qualified Data.ByteString.Char8 as S8 -import FileStorage (retrieveFile) +import FileStorage (retrieveFile, filterFiles) import Foundation import Models.Inode import Utils.HandlerUtils + ( lookupAuth, handleApiCall, sendErrorOrRedirect ) import FileSystemServiceClient.FileSystemServiceClient hiding (mimeType) -import Crypto.KeyEncrptionKey +import Crypto.KeyEncrptionKey ( getKeyForInode ) import ClassyPrelude ( ($), Show(show), @@ -31,18 +33,31 @@ import ClassyPrelude Int, fromMaybe, MonadIO(liftIO), - String ) + String, + Text, + (.), + print, + Bool(True), + intercalate, + (<>), + map ) import Crypto.CryptoConduit +import FileSystemServiceClient.FileSystemServiceClient (FileSystemServiceClient(getInodeContent)) +import Models.RestApiStatus (RestApiStatus(RestApiStatus)) +import Models.Path (fromMultiPiece) -getPreviewR :: Int -> String -> Handler TypedContent -getPreviewR inodeId _ = do - App {fileSystemServiceClient = FileSystemServiceClient {getInodeInfo = getInodeInfo'}, keyEncrptionKey = kek} <- getYesod +getPreviewR :: [Text] -> Handler TypedContent +getPreviewR path = do + App {fileSystemServiceClient = FileSystemServiceClient {getInodeContent = getInodeContent'}, keyEncrptionKey = kek} <- getYesod bearerToken <- lookupAuth - (responseBody', responseStatusCode, responseStatusMessage) <- liftIO $ getInodeInfo' bearerToken $ show inodeId - inode <- handleApiCall responseBody' responseStatusCode responseStatusMessage - (key, iv) <- liftIO $ getKeyForInode kek inode - respondSource (S8.pack $ fromMaybe "application/octet-stream" (mimeType inode)) $ - retrieveFile inode - .| decryptConduit key iv mempty - .| awaitForever sendChunkBS + (responseBody', responseStatusCode, responseStatusMessage) <- liftIO $ getInodeContent' bearerToken $ fromMultiPiece path + inodes <- handleApiCall responseBody' responseStatusCode responseStatusMessage + case map (\i -> (i,filterFiles i))inodes of + [(inode,True)] -> do + (key, iv) <- liftIO $ getKeyForInode kek inode + respondSource (S8.pack $ fromMaybe "application/octet-stream" (mimeType inode)) $ + retrieveFile inode + .| decryptConduit key iv mempty + .| awaitForever sendChunkBS + _ -> sendErrorOrRedirect status400 $ toJSON $ RestApiStatus "Can not preview a folder." "Bad Request" diff --git a/src/Models/Path.hs b/src/Models/Path.hs index 1da6887..95776ab 100644 --- a/src/Models/Path.hs +++ b/src/Models/Path.hs @@ -1,9 +1,23 @@ -- | {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + module Models.Path where import ClassyPrelude -import ClassyPrelude.Yesod + ( otherwise, + ($), + Show, + Generic, + Semigroup((<>)), + unpack, + String, + ByteString, + Text, + intercalate, + isPrefixOf) +import ClassyPrelude.Yesod ( ToJSON(toJSON) ) +import Data.ByteString.Char8 (pack) @@ -17,6 +31,14 @@ newtype Path = Path { instance ToJSON Path where toJSON (Path path) = toJSON $ addLeadingSlash path + +toByteString :: Path -> ByteString +toByteString (Path path) = pack path + + +fromMultiPiece :: [Text] -> Path +fromMultiPiece pathPieces = Path $unpack $ "/" <> intercalate "/" pathPieces + addLeadingSlash :: String -> String addLeadingSlash path | "/" `isPrefixOf` path = path diff --git a/src/Utils/HandlerUtils.hs b/src/Utils/HandlerUtils.hs index 9490714..e35170b 100644 --- a/src/Utils/HandlerUtils.hs +++ b/src/Utils/HandlerUtils.hs @@ -51,8 +51,12 @@ handleApiCall body statusCode statusMessage Error e -> do liftIO $ print e sendInternalError - | 400 <= statusCode && statusCode < 500 = sendErrorOrRedirect (Status statusCode statusMessage) body --sendResponseStatus (Status statusCode statusMessage) body - | otherwise = sendInternalError + | 400 <= statusCode && statusCode < 500 = do + liftIO $ print "4XX domain error" + sendErrorOrRedirect (Status statusCode statusMessage) body --sendResponseStatus (Status statusCode statusMessage) body + | otherwise = do + liftIO $ print body + sendInternalError sendErrorOrRedirect :: (MonadHandler m, RedirectUrl (HandlerSite m) (Route App, [(Text, Text)])) => Status -> Value -> m a sendErrorOrRedirect status body = From ca7c0f86d66fd333abd8adf510b7bdb1829ebe7c Mon Sep 17 00:00:00 2001 From: qvalentin Date: Thu, 16 Jun 2022 10:14:48 +0200 Subject: [PATCH 15/35] refactoring --- src/FileStorage.hs | 26 ++++++++---------- src/Handler/Delete.hs | 11 +++----- src/Handler/Download.hs | 16 +++++++----- src/Handler/Health.hs | 58 +++++++++++++++++++++++++++-------------- src/Handler/Home.hs | 9 +++---- src/Handler/Upload.hs | 35 ++++++++++++++++--------- src/Utils/ZipFile.hs | 25 ++++++++---------- 7 files changed, 101 insertions(+), 79 deletions(-) diff --git a/src/FileStorage.hs b/src/FileStorage.hs index bc62c03..40f6859 100644 --- a/src/FileStorage.hs +++ b/src/FileStorage.hs @@ -1,36 +1,32 @@ -- | - module FileStorage where + import ClassyPrelude -import Yesod -import Models.Inode import ClassyPrelude.Yesod -import System.Directory import Data.Time import GHC.IO.FD (openFile) - - +import Models.Inode +import System.Directory +import Yesod storeFile :: MonadResource m => Inode -> IO (ConduitT ByteString o m ()) storeFile inode = do let id = show $ fileSystemId inode - createDirectoryIfMissing True $ take 1 id - return $sinkFileCautious (getPathFromFileId id) - + createDirectoryIfMissing True $ take 1 id + return $sinkFileCautious (getPathFromFileId id) -retrieveFile :: MonadResource m => Inode ->ConduitT i ByteString m () -retrieveFile inode= do +retrieveFile :: MonadResource m => Inode -> ConduitT i ByteString m () +retrieveFile inode = do let id = show $ fileSystemId inode sourceFile (getPathFromFileId id) getPathFromFileId :: String -> String -getPathFromFileId id=take 1 id ++ ("/" ++id) +getPathFromFileId id = take 1 id ++ ("/" ++ id) getInodeModifcationTime :: Inode -> IO UTCTime -getInodeModifcationTime inode = do +getInodeModifcationTime inode = let id = show $ fileSystemId inode - getModificationTime (getPathFromFileId id) - + in getModificationTime (getPathFromFileId id) filterFiles :: Inode -> Bool filterFiles file = case mimeType file of diff --git a/src/Handler/Delete.hs b/src/Handler/Delete.hs index 317dc70..b6fb0eb 100644 --- a/src/Handler/Delete.hs +++ b/src/Handler/Delete.hs @@ -23,14 +23,9 @@ deleteDeleteR path = do App {fileSystemServiceClient = FileSystemServiceClient {deleteInode = deleteInode}} <- getYesod authToken <- lookupAuth (responseBody, responseStatusCode, responseStatusMessage) <- liftIO $ deleteInode authToken path - case responseStatusCode of - 200 -> do - case fromJSON responseBody of - Success inodes -> do - liftIO $ mapM_ deleteFile (filter filterFiles inodes) -- Todo: check if file exists - return responseBody - Error _ -> sendInternalError - _ -> sendResponseStatus (Status responseStatusCode responseStatusMessage) responseBody + inodes <- handleApiCall responseBody responseStatusCode responseStatusMessage + liftIO $ mapM_ deleteFile (filter filterFiles inodes) -- Todo: check if file exists + return responseBody deleteFile :: Inode -> IO () deleteFile file = removeFile $ getPathFromFileId (show $ fileSystemId file) diff --git a/src/Handler/Download.hs b/src/Handler/Download.hs index ac06691..7907bb8 100644 --- a/src/Handler/Download.hs +++ b/src/Handler/Download.hs @@ -37,7 +37,9 @@ import ClassyPrelude maybe, pack, parseTimeM, + print, pure, + putStrLn, readFile, tshow, unpack, @@ -115,15 +117,17 @@ getDownloadR path = do ) paths - inodes <- concat <$> - mapM - ( \(responseBody, responseStatusCode, responseStatusMessage) -> do - handleApiCall responseBody responseStatusCode responseStatusMessage - ) - apiResponses + inodes <- + concat + <$> mapM + ( \(responseBody, responseStatusCode, responseStatusMessage) -> do + handleApiCall responseBody responseStatusCode responseStatusMessage + ) + apiResponses case inodes of [singleInode] -> do + liftIO $ print $ size singleInode addHeader "Content-Disposition" $ pack ("attachment; filename=\"" ++ Models.Inode.name singleInode ++ "\"") addHeader "Content-Length" $ tshow $ size singleInode (key, iv) <- liftIO $ getKeyForInode kek singleInode diff --git a/src/Handler/Health.hs b/src/Handler/Health.hs index bdfb38c..3ad65f6 100644 --- a/src/Handler/Health.hs +++ b/src/Handler/Health.hs @@ -1,42 +1,62 @@ --- | -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +-- | module Handler.Health where +import ClassyPrelude + ( FilePath, + Generic, + IO, + Int, + Integer, + IsSequence (filterM), + MonadIO (liftIO), + Show, + String, + Traversable (mapM), + concat, + length, + map, + sum, + ($), + (<$>), + (), + (=<<), + ) import Foundation -import ClassyPrelude hiding (Handler) -import Yesod.Core import qualified Network.HTTP.Types as HttpTypes +import Settings (AppSettings (AppSettings), appProfile) import System.Directory - ( doesDirectoryExist, getFileSize, listDirectory ) -import Settings (AppSettings(AppSettings), appProfile) - + ( doesDirectoryExist, + getFileSize, + listDirectory, + ) +import Yesod.Core -data HealthInfo =HealthInfo - { version :: String - , deploymentType :: String - , actualFilesSize :: Integer - , fileCount :: Int +data HealthInfo = HealthInfo + { version :: String, + deploymentType :: String, + actualFilesSize :: Integer, + fileCount :: Int } deriving (Show, Generic) -instance ToJSON HealthInfo +instance ToJSON HealthInfo getHealthR :: Handler Value getHealthR = do - App{appSettings = AppSettings {appProfile = deploymentType}} <- getYesod + App {appSettings = AppSettings {appProfile = deploymentType}} <- getYesod files <- liftIO $ concat <$> (mapM listDirectoryRelative =<< (filterM doesDirectoryExist =<< listDirectory ".")) actualFilesSize <- liftIO $ sum <$> mapM getFileSize files let response = HealthInfo - { version = "0.2.1" :: String - , deploymentType = deploymentType - , actualFilesSize = actualFilesSize - , fileCount = length files + { version = "0.2.1" :: String, + deploymentType = deploymentType, + actualFilesSize = actualFilesSize, + fileCount = length files } returnJson response - listDirectoryRelative :: FilePath -> IO [FilePath] listDirectoryRelative x = map (x ) <$> listDirectory x diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 87c438b..56102d6 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -1,13 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE QuasiQuotes #-} + module Handler.Home where +import ClassyPrelude hiding (Handler) import Foundation import Yesod.Core -import ClassyPrelude hiding (Handler) - - getHomeR :: Handler String getHomeR = - return "hallo" + return "/ Endpoint of the FileHandler Api, you should not have got here." diff --git a/src/Handler/Upload.hs b/src/Handler/Upload.hs index dfd3b0c..8476abe 100644 --- a/src/Handler/Upload.hs +++ b/src/Handler/Upload.hs @@ -10,13 +10,18 @@ import ClassyPrelude hiding (Handler) import ClassyPrelude.Yesod ( ConduitT, FileInfo (fileContentType), + Response (responseBody), + defaultMakeLogger, + lengthC, + lengthCE, runConduitRes, - (.|), defaultMakeLogger, Response (responseBody) + (.|), ) import Crypto.Cipher.AES import Crypto.Cipher.Types (BlockCipher, IV, cipherInit, makeIV) import Crypto.CryptoConduit (encryptConduit) import Crypto.Error +import Crypto.Init import Crypto.KeyEncrptionKey hiding (initCipher, initIV) import Crypto.Random import Crypto.Types @@ -37,7 +42,9 @@ import FileSystemServiceClient.FileSystemServiceClient ) import Foundation (App (App, fileSystemServiceClient, keyEncrptionKey), Handler) import Models.Inode (Inode (fileSystemId)) +import Models.Path (Path (Path)) import Network.HTTP.Types (Status (Status)) +import System.Directory (createDirectoryIfMissing, doesDirectoryExist) import UnliftIO.Resource import Utils.HandlerUtils import Yesod.Core @@ -54,11 +61,8 @@ import Yesod.Core sendResponseStatus, ) import Yesod.Core.Handler (sendResponseCreated) -import Crypto.Init -import System.Directory (createDirectoryIfMissing) -import Yesod.Core.Types (loggerPutStr) +import Yesod.Core.Types (FileInfo (fileSourceRaw), loggerPutStr) import Prelude (read) -import Models.Path (Path(Path)) postUploadR :: Handler Value postUploadR = do @@ -68,7 +72,7 @@ postUploadR = do case lookupSingleFile files of Nothing -> invalidArgs ["Missing required File."] Just file -> do - inodeToCreate <- lookupUploadedInode $ Just (Text.unpack $ fileContentType file) + inodeToCreate <- lookupUploadedInode file case inodeToCreate of Nothing -> invalidArgs ["Missing required Header."] Just inode -> do @@ -82,24 +86,32 @@ postUploadR = do return responseBody _ -> sendInternalError -lookupUploadedInode :: MonadHandler m => Maybe String -> m (Maybe UploadedInode) -lookupUploadedInode mimeType = do +lookupUploadedInode :: MonadHandler m => FileInfo -> m (Maybe UploadedInode) +lookupUploadedInode fileInfo = do + let mimeType = Just (Text.unpack $ fileContentType fileInfo) relativePath <- lookupHeader $ Data.CaseInsensitive.mk "X-FF-RELATIVE-PATH" parentPath <- lookupHeader $ Data.CaseInsensitive.mk "X-FF-PARENT-PATH" - size <- lookupHeader $ Data.CaseInsensitive.mk "X-FF-SIZE" - return $ UploadedInode <$> (Path . S8.unpack <$> parentPath) <*> (Path . S8.unpack <$> relativePath) <*> (read . S8.unpack <$> size) <*> mimeType + size <- getRealFileSize fileInfo + return $ UploadedInode <$> (Path . S8.unpack <$> parentPath) <*> (Path . S8.unpack <$> relativePath) <*> Just size <*> mimeType lookupSingleFile :: [(Text.Text, FileInfo)] -> Maybe FileInfo lookupSingleFile [("file", file)] = Just file lookupSingleFile _ = Nothing +getRealFileSize :: MonadHandler m => FileInfo -> m Integer +getRealFileSize fileInfo = do + liftIO $ + runConduitRes $ + fileSource fileInfo + .| lengthCE + -- this creates the encryptionKey by generating it makeAllocateResource :: KeyEncryptionKey -> Inode -> IO (AES256, IV AES256) makeAllocateResource kek inode = do secretKey :: Key AES256 ByteString <- genSecretKey (undefined :: AES256) 32 let Key keyBytes = secretKey ivBytes <- genRandomIV (undefined :: AES256) - createDirectoryIfMissing True $ "keys/" <> take 1 (show $ fileSystemId inode ) + createDirectoryIfMissing True $ "keys/" <> take 1 (show $ fileSystemId inode) writeFile ("keys/" <> getPathFromFileId (show $ fileSystemId inode) ++ ".key") (encryptWithKek kek keyBytes) writeFile ("keys/" <> getPathFromFileId (show $ fileSystemId inode) ++ ".iv") ivBytes @@ -113,4 +125,3 @@ makeFreeResource fileInfo inode (cipher, iv) = do fileSource fileInfo .| encryptConduit cipher iv mempty .| fileDest - diff --git a/src/Utils/ZipFile.hs b/src/Utils/ZipFile.hs index 0fc5699..f3f3ad5 100644 --- a/src/Utils/ZipFile.hs +++ b/src/Utils/ZipFile.hs @@ -1,18 +1,19 @@ --- | {-# LANGUAGE OverloadedStrings #-} +-- | module Utils.ZipFile where + import ClassyPrelude -import qualified Models.Inode -import Codec.Archive.Zip.Conduit.Zip import ClassyPrelude.Conduit -import Data.Time -import FileStorage (retrieveFile, getInodeModifcationTime) +import Codec.Archive.Zip.Conduit.Zip import Crypto.Cipher.AES import Crypto.Cipher.Types import Crypto.CryptoConduit (decryptConduit) +import Data.Time +import FileStorage (getInodeModifcationTime, retrieveFile) +import qualified Models.Inode -createZip :: [(Models.Inode.Inode,(AES256, IV AES256))] -> FilePath -> IO () +createZip :: [(Models.Inode.Inode, (AES256, IV AES256))] -> FilePath -> IO () createZip inodes filename = do timeZone <- liftIO getCurrentTimeZone runConduitRes $ @@ -20,8 +21,8 @@ createZip inodes filename = do .| void (zipStream zipOptions) .| sinkFile filename -generateZipEntries :: (MonadIO m, MonadResource m) => [(Models.Inode.Inode,(AES256, IV AES256))] -> TimeZone -> ConduitM () (ZipEntry, ZipData m) m () -generateZipEntries ((currentInode,(key,iv)) : nextInodes) timeZone = do +generateZipEntries :: (MonadIO m, MonadResource m) => [(Models.Inode.Inode, (AES256, IV AES256))] -> TimeZone -> ConduitM () (ZipEntry, ZipData m) m () +generateZipEntries ((currentInode, (key, iv)) : nextInodes) timeZone = do let nameInZip = fromMaybe (Models.Inode.name currentInode) $ Models.Inode.path currentInode let size' = Models.Inode.size currentInode timeStamp <- liftIO $ getTimestampForInode currentInode @@ -33,7 +34,7 @@ generateZipEntries ((currentInode,(key,iv)) : nextInodes) timeZone = do zipEntryExternalAttributes = Nothing } - yield (entry, ZipDataSource $retrieveFile currentInode .| decryptConduit key iv mempty ) + yield (entry, ZipDataSource $retrieveFile currentInode .| decryptConduit key iv mempty) generateZipEntries nextInodes timeZone return () generateZipEntries [] _ = return () @@ -58,8 +59,4 @@ getTimestampForInode inode = do convertUnixTimeStamp :: Int -> Maybe UTCTime convertUnixTimeStamp ts = do - let i = parseTimeM True defaultTimeLocale "%s" (show ts) :: Maybe UTCTime - case i of - Just timeWithoutTimezone -> do - Just timeWithoutTimezone - Nothing -> Nothing + parseTimeM True defaultTimeLocale "%s" (show ts) :: Maybe UTCTime From c155f5ccaa29d260dd34a1aef3281cd474ca3611 Mon Sep 17 00:00:00 2001 From: qvalentin Date: Thu, 16 Jun 2022 11:35:57 +0200 Subject: [PATCH 16/35] Add preflight to upload to prevent DDOS by uploading large files without authentication --- .../FileSystemServiceClient.hs | 106 +++++++++++------- src/Handler/Upload.hs | 31 ++++- 2 files changed, 92 insertions(+), 45 deletions(-) diff --git a/src/FileSystemServiceClient/FileSystemServiceClient.hs b/src/FileSystemServiceClient/FileSystemServiceClient.hs index b3c3f0f..a86532a 100644 --- a/src/FileSystemServiceClient/FileSystemServiceClient.hs +++ b/src/FileSystemServiceClient/FileSystemServiceClient.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE UndecidableInstances #-} @@ -6,48 +7,49 @@ -- | module FileSystemServiceClient.FileSystemServiceClient where +import ClassyPrelude hiding (encodeUtf8, intercalate, pack) import qualified Control.Monad.IO.Class import Control.Monad.Trans.Resource import Data.Aeson +import qualified Data.ByteString as S8 import Data.ByteString.Char8 (ByteString) import Data.Text import Data.Text.Encoding (encodeUtf8) import GHC.Generics +import Models.Path (Path, fromMultiPiece, toByteString) import Network.HTTP.Req - ( (/:), - (=:), - defaultHttpConfig, - header, - http, - jsonResponse, - req, - responseBody, - responseHeader, - responseStatusCode, - responseStatusMessage, - runReq, - DELETE(DELETE), - GET(GET), - HttpConfig(httpConfigCheckResponse), - NoReqBody(NoReqBody), - POST(POST), - ReqBodyJson(ReqBodyJson) ) + ( DELETE (DELETE), + GET (GET), + HttpConfig (httpConfigCheckResponse), + NoReqBody (NoReqBody), + POST (POST), + ReqBodyJson (ReqBodyJson), + defaultHttpConfig, + header, + http, + jsonResponse, + req, + responseBody, + responseHeader, + responseStatusCode, + responseStatusMessage, + runReq, + (/:), + (=:), + ) import qualified Network.HTTP.Req as Req import Settings -import ClassyPrelude hiding (intercalate, pack, encodeUtf8) -import Models.Path (Path, fromMultiPiece, toByteString) -import qualified Data.ByteString as S8 data FileSystemServiceClient = FileSystemServiceClient { deleteInode :: Text -> [Text] -> IO (Value, Int, ByteString), - createInode :: Text -> UploadedInode -> IO (Value, Int, ByteString), - getInodeInfo ::Text -> String -> IO (Value, Int, ByteString), - getInodeContent :: Text -> Path -> IO (Value, Int, ByteString) + createInode :: Text -> UploadedInode -> IO (Value, Int, ByteString), + preflightInode :: Text -> PreflightInode -> IO (Value, Int, ByteString), + getInodeInfo :: Text -> String -> IO (Value, Int, ByteString), + getInodeContent :: Text -> Path -> IO (Value, Int, ByteString) } data UploadedInode = UploadedInode - { - parentPath :: Path, + { parentPath :: Path, relativePath :: Path, size :: Integer, mimeType :: String @@ -56,6 +58,14 @@ data UploadedInode = UploadedInode instance ToJSON UploadedInode +data PreflightInode = PreflightInode + { parentPath :: Path, + relativePaths :: [Path] + } + deriving (Show, Generic) + +instance ToJSON PreflightInode + httpConfigDontCheckResponse :: p1 -> p2 -> p3 -> Maybe a httpConfigDontCheckResponse _ _ _ = Nothing @@ -64,47 +74,60 @@ makeFileSystemServiceClient fileSystemServiceSettings = FileSystemServiceClient { deleteInode = makeDeleteInode fileSystemServiceSettings, createInode = makeCreateInode fileSystemServiceSettings, + preflightInode = makePreflightInode fileSystemServiceSettings, getInodeInfo = makeGetInodeInfo fileSystemServiceSettings, - getInodeContent = makeGetInodeContent fileSystemServiceSettings + getInodeContent = makeGetInodeContent fileSystemServiceSettings } -makeDeleteInode :: FileSystemServiceSettings -> Text -> [Text] -> IO (Value, Int, ByteString) +makeDeleteInode :: FileSystemServiceSettings -> Text -> [Text] -> IO (Value, Int, ByteString) makeDeleteInode r@FileSystemServiceSettings {url = url, port = port} authorization path = runReq (defaultHttpConfig {httpConfigCheckResponse = httpConfigDontCheckResponse}) $ do r <- req DELETE - (http (pack url) /: "api" /: "filesystem" /: "delete") + (http (pack url) /: "api" /: "filesystem" /: "delete") NoReqBody jsonResponse - (oAuth2Bearer' (encodeUtf8 authorization) <> Req.port port - <> header "X-FF-PATH" (toByteString $ fromMultiPiece path)) + ( oAuth2Bearer' (encodeUtf8 authorization) <> Req.port port + <> header "X-FF-PATH" (toByteString $ fromMultiPiece path) + ) return (responseBody r, responseStatusCode r, responseStatusMessage r) oAuth2Bearer' token = header "Authorization" ("Bearer " <> token) -makeCreateInode :: FileSystemServiceSettings -> Text -> UploadedInode -> IO (Value, Int, ByteString) +makeCreateInode :: FileSystemServiceSettings -> Text -> UploadedInode -> IO (Value, Int, ByteString) makeCreateInode r@FileSystemServiceSettings {url = url, port = port} authorization uploadedInode = runReq (defaultHttpConfig {httpConfigCheckResponse = httpConfigDontCheckResponse}) $ do r <- req POST -- method --(http (DataText.pack restUrl) /: "t/os3vu-1615111052/post") - (http (pack url) /: "api" /: "filesystem" /: "upload") + (http (pack url) /: "api" /: "filesystem" /: "upload") (ReqBodyJson uploadedInode) -- use built-in options or add your own jsonResponse (oAuth2Bearer' (encodeUtf8 authorization) <> Req.port port) -- parentID not in Headers return (responseBody r, responseStatusCode r, responseStatusMessage r) -makeGetInodeInfo :: FileSystemServiceSettings -> Text -> String -> IO (Value, Int, ByteString) +makePreflightInode :: FileSystemServiceSettings -> Text -> PreflightInode -> IO (Value, Int, ByteString) +makePreflightInode r@FileSystemServiceSettings {url = url, port = port} authorization preflightInode = runReq (defaultHttpConfig {httpConfigCheckResponse = httpConfigDontCheckResponse}) $ do + r <- + req + POST -- method + (http (pack url) /: "api" /: "filesystem" /: "preflight") + (ReqBodyJson preflightInode) + jsonResponse + (oAuth2Bearer' (encodeUtf8 authorization) <> Req.port port) -- parentID not in Headers + return (responseBody r, responseStatusCode r, responseStatusMessage r) + +makeGetInodeInfo :: FileSystemServiceSettings -> Text -> String -> IO (Value, Int, ByteString) makeGetInodeInfo r@FileSystemServiceSettings {url = url, port = port} authorization id = runReq (defaultHttpConfig {httpConfigCheckResponse = httpConfigDontCheckResponse}) $ do r <- req GET -- method - (http (pack url) /: "v1" /: "filesystem" /: pack id /: "info") -- safe by construction URL + (http (pack url) /: "v1" /: "filesystem" /: pack id /: "info") -- safe by construction URL --(http (DataText.pack restUrl) /: "v1" /: "filesystem" /: id /: "info" ) -- safe by construction URL NoReqBody -- use built-in options or add your own jsonResponse -- specify how to interpret response (oAuth2Bearer' (encodeUtf8 authorization) <> Req.port port) - -- mempty -- query params, headers, explicit port number, etc. + -- mempty -- query params, headers, explicit port number, etc. return (responseBody r, responseStatusCode r, responseStatusMessage r) makeGetInodeContent :: FileSystemServiceSettings -> Text -> Path -> IO (Value, Int, ByteString) @@ -112,12 +135,13 @@ makeGetInodeContent r@FileSystemServiceSettings {url = url, port = port} authori r <- req GET -- method - (http (pack url) /: "api" /: "filesystem" /: "download") -- safe by construction URL + (http (pack url) /: "api" /: "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 jsonResponse -- specify how to interpret response - (oAuth2Bearer' (encodeUtf8 authorization) - <> Req.port port - <> header "X-FF-PATH" (toByteString path)) - -- mempty -- query params, headers, explicit port number, etc. + ( oAuth2Bearer' (encodeUtf8 authorization) + <> Req.port port + <> header "X-FF-PATH" (toByteString path) + ) + -- mempty -- query params, headers, explicit port number, etc. return (responseBody r, responseStatusCode r, responseStatusMessage r) diff --git a/src/Handler/Upload.hs b/src/Handler/Upload.hs index 8476abe..d820c21 100644 --- a/src/Handler/Upload.hs +++ b/src/Handler/Upload.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -10,6 +12,9 @@ import ClassyPrelude hiding (Handler) import ClassyPrelude.Yesod ( ConduitT, FileInfo (fileContentType), + MonadHandler (HandlerSite), + RedirectUrl, + RenderRoute (Route), Response (responseBody), defaultMakeLogger, lengthC, @@ -37,7 +42,8 @@ import Data.CaseInsensitive (mk) import qualified Data.Text as Text import FileStorage (filterFiles, getPathFromFileId, storeFile) import FileSystemServiceClient.FileSystemServiceClient - ( FileSystemServiceClient (FileSystemServiceClient, createInode), + ( FileSystemServiceClient (FileSystemServiceClient, createInode, preflightInode), + PreflightInode (PreflightInode), UploadedInode (UploadedInode), ) import Foundation (App (App, fileSystemServiceClient, keyEncrptionKey), Handler) @@ -66,14 +72,15 @@ import Prelude (read) postUploadR :: Handler Value postUploadR = do - App {fileSystemServiceClient = FileSystemServiceClient {createInode = createInode}, keyEncrptionKey = kek} <- getYesod + App {fileSystemServiceClient = fssc, keyEncrptionKey = kek} <- getYesod + let FileSystemServiceClient {createInode = createInode} = fssc authToken <- lookupAuth + performPreflight fssc authToken (_params, files) <- runRequestBody case lookupSingleFile files of Nothing -> invalidArgs ["Missing required File."] Just file -> do - inodeToCreate <- lookupUploadedInode file - case inodeToCreate of + lookupUploadedInode file >>= \case Nothing -> invalidArgs ["Missing required Header."] Just inode -> do (responseBody, responseStatusCode, responseStatusMessage) <- liftIO $ createInode authToken inode @@ -86,6 +93,22 @@ postUploadR = do return responseBody _ -> sendInternalError +performPreflight :: (MonadHandler m, RedirectUrl (HandlerSite m) (Route App, [(Text, Text)])) => FileSystemServiceClient -> Text -> m () +performPreflight FileSystemServiceClient {preflightInode = _preflightInode} authToken = do + lookupPreflightInode >>= \case + Nothing -> invalidArgs ["Missing required Header: Need X-FF-RELATIVE-PATH and X-FF-PARENT-PATH headers"] + Just preflightInode -> do + (responseBody, responseStatusCode, responseStatusMessage) <- liftIO $ _preflightInode authToken preflightInode + if responseStatusCode /= 200 + then sendErrorOrRedirect (Status responseStatusCode responseStatusMessage) responseBody + else return () + +lookupPreflightInode :: MonadHandler m => m (Maybe PreflightInode) +lookupPreflightInode = do + relativePath <- lookupHeader $ Data.CaseInsensitive.mk "X-FF-RELATIVE-PATH" + parentPath <- lookupHeader $ Data.CaseInsensitive.mk "X-FF-PARENT-PATH" + return $ PreflightInode <$> (Path . S8.unpack <$> parentPath) <*> (ClassyPrelude.singleton . Path . S8.unpack <$> relativePath) + lookupUploadedInode :: MonadHandler m => FileInfo -> m (Maybe UploadedInode) lookupUploadedInode fileInfo = do let mimeType = Just (Text.unpack $ fileContentType fileInfo) From b2b490bab29197d8e53987b989028216bd3a8043 Mon Sep 17 00:00:00 2001 From: qvalentin Date: Thu, 16 Jun 2022 18:52:10 +0200 Subject: [PATCH 17/35] Prepare for adding mongoDB as a keystore --- config/settings.yml | 9 ++++-- package.yaml | 73 +++++++++++++++++++++--------------------- src/Application.hs | 78 ++++++++++++++++++++++++++++----------------- src/Foundation.hs | 26 ++++++++++++--- src/Handler/Home.hs | 6 ++-- src/Settings.hs | 2 ++ stack.yaml | 8 ++--- stack.yaml.lock | 9 +++++- 8 files changed, 132 insertions(+), 79 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index fee6c43..b52f687 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -1,5 +1,3 @@ - - appProfile: "_env:APP_PROFILE:prod" fileSystemServiceSettings: @@ -7,3 +5,10 @@ fileSystemServiceSettings: port: "_env:FILESYSTEMSERVICE_PORT:8080" encryptionPassword: "_env:ENCRYPTION_PASSWORD:changeThis" + +database: + user: "yesodMongoTemplate" + password: "yesodMongoTemplate" + host: "localhost" + database: "yesodMongoTemplate" + connections: 10 diff --git a/package.yaml b/package.yaml index 69a3fd7..6b715a6 100644 --- a/package.yaml +++ b/package.yaml @@ -1,55 +1,56 @@ -name: FileHandlerYesod +name: FileHandlerYesod version: "0.1.0" dependencies: -- aeson -- base -- bytestring -- case-insensitive -- classy-prelude -- classy-prelude-conduit -- classy-prelude-yesod -- cryptonite -- directory -- file-embed -- filepath -- http-types -- memory -- mtl -- req -- resourcet -- temporary -- text -- time -- wai -- wai-extra -- wai-cors -- warp -- yaml -- yesod -- yesod-core -- zip -- zip-stream - - + - aeson + - base + - bytestring + - case-insensitive + - classy-prelude + - classy-prelude-conduit + - classy-prelude-yesod + - cryptonite + - directory + - file-embed + - filepath + - http-types + - memory + - mtl + - req + - resourcet + - temporary + - text + - time + - wai + - wai-cors + - wai-extra + - warp + - yaml + - yesod + - yesod-core + - zip + - zip-stream + - persistent + - yesod-persistent + - persistent-mongoDB + - mongoDB # The library contains all of our application code. The executable # defined below is just a thin wrapper. library: source-dirs: src - # Runnable executable for our application executables: FileHandlerYesod: main: Main.hs source-dirs: app ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N + - -threaded + - -rtsopts + - -with-rtsopts=-N dependencies: - - FileHandlerYesod + - FileHandlerYesod default-extensions: NoImplicitPrelude diff --git a/src/Application.hs b/src/Application.hs index b150530..ac8ed41 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -5,42 +5,60 @@ module Application where import ClassyPrelude - ( ($), - Monad(return), - Num((*)), - Bool(False, True), - Maybe(Just, Nothing), - IO, - const ) + ( Bool (False, True), + IO, + Maybe (Just, Nothing), + Monad (return), + Num ((*)), + const, + ($), + ) +import ClassyPrelude.Yesod (PersistConfig (createPoolConfig)) import Crypto.KeyEncrptionKey (createKeyEncrptionKey, getOrCreateKekIV) -import Data.Yaml.Config ( loadYamlSettingsArgs, useEnv ) +import Data.Yaml.Config (loadYamlSettingsArgs, useEnv) import FileSystemServiceClient.FileSystemServiceClient (makeFileSystemServiceClient) import Foundation - ( Route(ErrorR, HomeR, DownloadR, UploadR, DeleteR, PreviewR, - HealthR), - App(..), - resourcesApp ) -import Handler.Delete ( deleteDeleteR ) -import Handler.Download ( getDownloadR ) -import Handler.Error ( getErrorR ) -import Handler.Health ( getHealthR ) -import Handler.Home ( getHomeR ) -import Handler.Preview ( getPreviewR ) -import Handler.Upload ( postUploadR ) + ( App (..), + Route + ( DeleteR, + DownloadR, + ErrorR, + HealthR, + HomeR, + PreviewR, + UploadR + ), + resourcesApp, + ) +import Handler.Delete (deleteDeleteR) +import Handler.Download (getDownloadR) +import Handler.Error (getErrorR) +import Handler.Health (getHealthR) +import Handler.Home (getHomeR) +import Handler.Preview (getPreviewR) +import Handler.Upload (postUploadR) import Network.Wai () -import Network.Wai.Handler.Warp ( run ) +import Network.Wai.Handler.Warp (run) import Network.Wai.Middleware.Cors - ( cors, - CorsResourcePolicy(CorsResourcePolicy, corsOrigins, corsMethods, - corsRequestHeaders, corsExposedHeaders, corsMaxAge, corsVaryOrigin, - corsRequireOrigin, corsIgnoreFailures) ) + ( CorsResourcePolicy + ( CorsResourcePolicy, + corsExposedHeaders, + corsIgnoreFailures, + corsMaxAge, + corsMethods, + corsOrigins, + corsRequestHeaders, + corsRequireOrigin, + corsVaryOrigin + ), + cors, + ) import Network.Wai.Parse () -import Network.Wai.Middleware.Cors () import Settings - ( AppSettings (encryptionPassword, fileSystemServiceSettings), + ( AppSettings (appDatabaseConf, encryptionPassword, fileSystemServiceSettings), configSettingsYmlValue, ) -import Yesod.Core ( toWaiApp, mkYesodDispatch ) +import Yesod.Core (mkYesodDispatch, toWaiApp) mkYesodDispatch "App" resourcesApp @@ -50,10 +68,12 @@ makeFoundation appSettings = do iv <- getOrCreateKekIV let keyEncrptionKey = createKeyEncrptionKey (encryptionPassword appSettings) iv + appConnPool <- createPoolConfig $ appDatabaseConf appSettings return App { appSettings = appSettings, + appConnPool = appConnPool, fileSystemServiceClient = fssC, keyEncrptionKey = keyEncrptionKey } @@ -77,9 +97,9 @@ appMain = do devCorsPolicy = Just CorsResourcePolicy - { corsOrigins = Just (["http://localhost:3000"],True), + { corsOrigins = Just (["http://localhost:3000"], True), corsMethods = ["GET", "POST", "DELETE"], - corsRequestHeaders = ["Authorization", "content-type", "X-FF-IDS", "X-FF-ID", "X-FF-NAME", "X-FF-PATH", "X-FF-SIZE","X-FF-PARENT-PATH","X-FF-RELATIVE-PATH","X-FF-PARENT-PATH"], + corsRequestHeaders = ["Authorization", "content-type", "X-FF-IDS", "X-FF-ID", "X-FF-NAME", "X-FF-PATH", "X-FF-SIZE", "X-FF-PARENT-PATH", "X-FF-RELATIVE-PATH", "X-FF-PARENT-PATH"], corsExposedHeaders = Just ["Content-Disposition"], corsMaxAge = Just $ 60 * 60 * 24, -- one day corsVaryOrigin = False, diff --git a/src/Foundation.hs b/src/Foundation.hs index 8ee7b64..7ce507a 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -5,14 +6,17 @@ module Foundation where -import ClassyPrelude +import ClassyPrelude hiding (Handler) +import ClassyPrelude.Yesod (YesodPersist (runDB), getYesod) +import Crypto.KeyEncrptionKey (KeyEncryptionKey) +import Database.Persist.MongoDB hiding (master) import FileSystemServiceClient.FileSystemServiceClient ( FileSystemServiceClient, ) import Network.Wai.Parse ( tempFileBackEnd, ) -import Settings (AppSettings) +import Settings (AppSettings (appDatabaseConf)) import Yesod.Core ( FileUpload (FileUploadDisk), RenderRoute (renderRoute), @@ -20,17 +24,29 @@ import Yesod.Core mkYesodData, parseRoutesFile, ) -import Crypto.KeyEncrptionKey (KeyEncryptionKey) +import Yesod.Persist.Core (YesodPersist (..)) data App = App { appSettings :: AppSettings, + appConnPool :: ConnectionPool, fileSystemServiceClient :: FileSystemServiceClient, - keyEncrptionKey :: KeyEncryptionKey + keyEncrptionKey :: KeyEncryptionKey } mkYesodData "App" $(parseRoutesFile "routes.yesodroutes") instance Yesod App where - maximumContentLength _ (Just (UploadR)) = Nothing + maximumContentLength _ (Just UploadR) = Nothing maximumContentLength _ _ = Just (2 * 1024 * 1024) -- 2 megabytes fileUpload _ _ = FileUploadDisk tempFileBackEnd + +-- How to run database actions. +instance YesodPersist App where + type YesodPersistBackend App = MongoContext + runDB :: ReaderT MongoContext Handler a -> Handler a + runDB action = do + master <- getYesod + runMongoDBPool + (mgAccessMode $ appDatabaseConf $ appSettings master) + action + (appConnPool master) diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 56102d6..1938109 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -4,9 +4,11 @@ module Handler.Home where import ClassyPrelude hiding (Handler) +import ClassyPrelude.Yesod (YesodPersist (runDB), insertEntity) +import FileSystemServiceClient.FileSystemServiceClient (PreflightInode (PreflightInode)) import Foundation import Yesod.Core getHomeR :: Handler String -getHomeR = - return "/ Endpoint of the FileHandler Api, you should not have got here." +getHomeR = do + return "root Endpoint of the FileHandler Api, you should not have got here." diff --git a/src/Settings.hs b/src/Settings.hs index 7e75954..6d0c019 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -19,6 +19,7 @@ import Data.Aeson ) import Data.FileEmbed (embedFile) import Data.Yaml (decodeEither') +import Database.Persist.MongoDB (MongoConf) import GHC.Generics import Network.Wai.Handler.Warp (HostPreference) import Yesod.Default.Config2 (applyEnvValue, configSettingsYml) @@ -30,6 +31,7 @@ import Yesod.Default.Util data AppSettings = AppSettings { appProfile :: String, + appDatabaseConf :: MongoConf, fileSystemServiceSettings :: FileSystemServiceSettings, encryptionPassword :: String } diff --git a/stack.yaml b/stack.yaml index 439c254..43affd6 100644 --- a/stack.yaml +++ b/stack.yaml @@ -20,7 +20,6 @@ resolver: url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/24.yaml - # User packages to be built. # Various formats can be used as shown in the example below. # @@ -31,7 +30,7 @@ resolver: # - auto-update # - wai packages: -- . + - . # Dependency packages to be pulled from upstream that are not in the resolver. # These entries can reference officially published versions as well as # forks / in-progress versions pinned to a git hash. For example: @@ -41,8 +40,9 @@ packages: # - git: https://github.com/commercialhaskell/stack.git # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a # -extra-deps: -- classy-prelude-yesod-1.5.0@sha256:8f7e183bdfd6d2ea9674284c4f285294ab086aff60d9be4e5d7d2f3c1a2b05b7,1330 +extra-deps: + - classy-prelude-yesod-1.5.0@sha256:8f7e183bdfd6d2ea9674284c4f285294ab086aff60d9be4e5d7d2f3c1a2b05b7,1330 + - persistent-mongoDB-2.13.0.0@sha256:66b9fcd3d3084068653e3898db867e5f49c4ff3a6040d595d549c52877220db5,2744 # Override default flag values for local packages and extra-deps # flags: {} diff --git a/stack.yaml.lock b/stack.yaml.lock index fc68686..5f376bc 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -5,12 +5,19 @@ packages: - completed: - hackage: classy-prelude-yesod-1.5.0@sha256:8f7e183bdfd6d2ea9674284c4f285294ab086aff60d9be4e5d7d2f3c1a2b05b7,1330 pantry-tree: sha256: ae84d4cc0e1daf985db6cdcf2ac92319531b8e60f547183cc46480d00aafbe20 size: 330 + hackage: classy-prelude-yesod-1.5.0@sha256:8f7e183bdfd6d2ea9674284c4f285294ab086aff60d9be4e5d7d2f3c1a2b05b7,1330 original: hackage: classy-prelude-yesod-1.5.0@sha256:8f7e183bdfd6d2ea9674284c4f285294ab086aff60d9be4e5d7d2f3c1a2b05b7,1330 +- completed: + pantry-tree: + sha256: 5ae7b1ac51a0b083934193a6d01eea132adfe038b007afc992af7499432dcca7 + size: 593 + hackage: persistent-mongoDB-2.13.0.0@sha256:66b9fcd3d3084068653e3898db867e5f49c4ff3a6040d595d549c52877220db5,2744 + original: + hackage: persistent-mongoDB-2.13.0.0@sha256:66b9fcd3d3084068653e3898db867e5f49c4ff3a6040d595d549c52877220db5,2744 snapshots: - completed: sha256: 06d844ba51e49907bd29cb58b4a5f86ee7587a4cd7e6cf395eeec16cba619ce8 From 6dacafc00a02b7a45cc560457b29754abb9881b7 Mon Sep 17 00:00:00 2001 From: qvalentin Date: Thu, 23 Jun 2022 18:32:48 +0200 Subject: [PATCH 18/35] Add first mongoDB queries --- config/settings.yml | 8 ++++---- docker-compose.yml | 31 +++++++++++++++++++++++++++++++ package.yaml | 1 + prepareDB.mongo | 11 +++++++++++ src/DBModels.hs | 35 +++++++++++++++++++++++++++++++++++ src/Handler/Download.hs | 30 +++++++++++++++++++++--------- src/Handler/Home.hs | 6 ++++-- src/Handler/Upload.hs | 22 ++++++++++++++-------- src/KeyStorage.hs | 13 +++++++++++++ 9 files changed, 134 insertions(+), 23 deletions(-) create mode 100644 docker-compose.yml create mode 100644 prepareDB.mongo create mode 100644 src/DBModels.hs create mode 100644 src/KeyStorage.hs diff --git a/config/settings.yml b/config/settings.yml index b52f687..13bd3c9 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -6,9 +6,9 @@ fileSystemServiceSettings: encryptionPassword: "_env:ENCRYPTION_PASSWORD:changeThis" -database: - user: "yesodMongoTemplate" - password: "yesodMongoTemplate" +appDatabaseConf: + user: root + password: example host: "localhost" - database: "yesodMongoTemplate" + database: filehandler connections: 10 diff --git a/docker-compose.yml b/docker-compose.yml new file mode 100644 index 0000000..b5df29a --- /dev/null +++ b/docker-compose.yml @@ -0,0 +1,31 @@ +version: '3.1' + +services: + + mongo: + image: mongo + ports: + - 27017:27017 + networks: + - db + environment: + MONGO_INITDB: root + MONGO_INITDB_ROOT_USERNAME: root + MONGO_INITDB_ROOT_PASSWORD: example + + mongo-express: + image: mongo-express + ports: + - 8081:8081 + networks: + - db + links: + - "mongo:db" + environment: + ME_CONFIG_MONGODB_ADMINUSERNAME: root + ME_CONFIG_MONGODB_ADMINPASSWORD: example + ME_CONFIG_MONGODB_URL: mongodb://root:example@mongo:27017/ + + +networks: + db: diff --git a/package.yaml b/package.yaml index 6b715a6..5f0d3a2 100644 --- a/package.yaml +++ b/package.yaml @@ -34,6 +34,7 @@ dependencies: - yesod-persistent - persistent-mongoDB - mongoDB + - template-haskell # The library contains all of our application code. The executable # defined below is just a thin wrapper. diff --git a/prepareDB.mongo b/prepareDB.mongo new file mode 100644 index 0000000..85f11f9 --- /dev/null +++ b/prepareDB.mongo @@ -0,0 +1,11 @@ + +db.createUser( + { + user: "root", + pwd: "example", // or cleartext password + roles: [ + { role: "readWrite", db: "filehandler" } + ] + } + ) + diff --git a/src/DBModels.hs b/src/DBModels.hs new file mode 100644 index 0000000..7cb90f3 --- /dev/null +++ b/src/DBModels.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module DBModels where + +import ClassyPrelude.Conduit +import ClassyPrelude.Yesod +import Control.Monad.Reader +import Database.Persist.MongoDB (MongoContext) +import Database.Persist.TH (mkPersist, mkPersistSettings, persistLowerCase, share) +import Language.Haskell.TH.Syntax + +let mongoSettings = mkPersistSettings (ConT ''MongoContext) + in share + [mkPersist mongoSettings] + [persistLowerCase| +EncKey + fsId String + cipherKey ByteString + cipherIv ByteString + deriving Show +|] diff --git a/src/Handler/Download.hs b/src/Handler/Download.hs index 7907bb8..4fd4d4c 100644 --- a/src/Handler/Download.hs +++ b/src/Handler/Download.hs @@ -1,10 +1,11 @@ +{-# HLINT ignore "Use join" #-} +{-# HLINT ignore "Redundant bracket" #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -{-# HLINT ignore "Use join" #-} - module Handler.Download where import ClassyPrelude @@ -18,7 +19,7 @@ import ClassyPrelude IsMap (lookup), IsString (fromString), Maybe (..), - Monad (return), + Monad (return, (>>=)), MonadIO (..), Monoid (mempty), Show (show), @@ -53,10 +54,14 @@ import ClassyPrelude ) import ClassyPrelude.Yesod ( ConduitM, + Entity (Entity), MonadHandler, MonadResource, + PersistQueryRead (selectFirst), + PersistUniqueRead (getBy), TypedContent, Value, + YesodPersist (runDB), addHeader, awaitForever, getYesod, @@ -64,6 +69,7 @@ import ClassyPrelude.Yesod lookupGetParam, respondSource, runConduitRes, + selectKeys, sendChunkBS, sendFile, sinkFile, @@ -76,8 +82,10 @@ import Crypto.CryptoConduit (decryptConduit) import Crypto.Init import Crypto.KeyEncrptionKey (KeyEncryptionKey, decryptWithKek, getKeyForInode) import Crypto.Types (Key (Key)) +import DBModels (EncKey (EncKey, encKeyCipherIv, encKeyCipherKey), EntityField (EncKeyFsId, EncKeyId)) import qualified Data.ByteString.Char8 as S8 import Data.Text (splitAt, splitOn) +import Database.Persist (PersistQueryRead (selectKeysRes), (==.)) import FileStorage (getInodeModifcationTime, getPathFromFileId, retrieveFile) import FileSystemServiceClient.FileSystemServiceClient ( FileSystemServiceClient @@ -97,7 +105,7 @@ import qualified Network.HTTP.Types as HttpTypes import System.Directory (doesDirectoryExist, removeFile) import System.IO.Temp (emptySystemTempFile) import UnliftIO.Resource (allocate) -import Utils.HandlerUtils (handleApiCall, lookupAuth) +import Utils.HandlerUtils (handleApiCall, lookupAuth, sendInternalError) import Utils.ZipFile import Yesod.Routes.TH.Types (flatten) @@ -130,11 +138,15 @@ getDownloadR path = do liftIO $ print $ size singleInode addHeader "Content-Disposition" $ pack ("attachment; filename=\"" ++ Models.Inode.name singleInode ++ "\"") addHeader "Content-Length" $ tshow $ size singleInode - (key, iv) <- liftIO $ getKeyForInode kek singleInode - respondSource (S8.pack $ fromMaybe "application/octet-stream" (mimeType singleInode)) $ - retrieveFile singleInode - .| decryptConduit key iv mempty - .| awaitForever sendChunkBS + --(key, iv) <- liftIO $ getKeyForInode kek singleInode + runDB (selectFirst ([EncKeyFsId ==. (fileSystemId singleInode)]) ([])) >>= \case + Nothing -> sendInternalError + Just (Entity _ encKey) -> do + let key' = initCipher $ Key (decryptWithKek kek $ encKeyCipherKey encKey) :: AES256 + respondSource (S8.pack $ fromMaybe "application/octet-stream" (mimeType singleInode)) $ + retrieveFile singleInode + .| decryptConduit (key') (initIV $ encKeyCipherIv encKey) mempty + .| awaitForever sendChunkBS multipleInodes -> do let archiveName = fromMaybe "Files" Nothing addHeader "Content-Disposition" ("attachment; filename=\"" ++ decodeUtf8 archiveName ++ ".zip" ++ "\"") diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 1938109..688f7fa 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -1,14 +1,16 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} module Handler.Home where import ClassyPrelude hiding (Handler) -import ClassyPrelude.Yesod (YesodPersist (runDB), insertEntity) +import ClassyPrelude.Yesod (PersistStoreWrite (insertKey), YesodPersist (runDB), insertEntity) +import DBModels (EncKey (EncKey)) import FileSystemServiceClient.FileSystemServiceClient (PreflightInode (PreflightInode)) import Foundation import Yesod.Core getHomeR :: Handler String getHomeR = do + let encKey' = EncKey "" "" + --runDB $ insertKey (EncKeyKey' "das") encKey' return "root Endpoint of the FileHandler Api, you should not have got here." diff --git a/src/Handler/Upload.hs b/src/Handler/Upload.hs index d820c21..8b64b15 100644 --- a/src/Handler/Upload.hs +++ b/src/Handler/Upload.hs @@ -3,6 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-} {-# OPTIONS_GHC -Wno-deprecations #-} -- | @@ -13,6 +14,7 @@ import ClassyPrelude.Yesod ( ConduitT, FileInfo (fileContentType), MonadHandler (HandlerSite), + PersistStoreWrite (insert), RedirectUrl, RenderRoute (Route), Response (responseBody), @@ -30,13 +32,14 @@ import Crypto.Init import Crypto.KeyEncrptionKey hiding (initCipher, initIV) import Crypto.Random import Crypto.Types +import DBModels (EncKey (EncKey), EntityField (EncKeyId)) import Data.Aeson ( Result (Error, Success), Value, fromJSON, object, ) -import Data.ByteArray hiding (take) +import Data.ByteArray hiding (pack, take) import qualified Data.ByteString.Char8 as S8 import Data.CaseInsensitive (mk) import qualified Data.Text as Text @@ -53,6 +56,7 @@ import Network.HTTP.Types (Status (Status)) import System.Directory (createDirectoryIfMissing, doesDirectoryExist) import UnliftIO.Resource import Utils.HandlerUtils +import Yesod (YesodPersist (runDB)) import Yesod.Core ( FileInfo, MonadHandler, @@ -88,7 +92,8 @@ postUploadR = do createdInodes <- handleApiCall responseBody responseStatusCode responseStatusMessage case filter filterFiles createdInodes of [singleInode] -> do - let alloc = makeAllocateResource kek singleInode + (alloc, encKey') <- liftIO $ makeAllocateResource kek singleInode + runDB $ insert encKey' (_, _) <- allocate alloc (makeFreeResource file singleInode) return responseBody _ -> sendInternalError @@ -129,16 +134,17 @@ getRealFileSize fileInfo = do .| lengthCE -- this creates the encryptionKey by generating it -makeAllocateResource :: KeyEncryptionKey -> Inode -> IO (AES256, IV AES256) +makeAllocateResource :: KeyEncryptionKey -> Inode -> IO (IO (AES256, IV AES256), EncKey) makeAllocateResource kek inode = do - secretKey :: Key AES256 ByteString <- genSecretKey (undefined :: AES256) 32 + secretKey :: Crypto.Types.Key AES256 ByteString <- genSecretKey (undefined :: AES256) 32 let Key keyBytes = secretKey ivBytes <- genRandomIV (undefined :: AES256) - createDirectoryIfMissing True $ "keys/" <> take 1 (show $ fileSystemId inode) - writeFile ("keys/" <> getPathFromFileId (show $ fileSystemId inode) ++ ".key") (encryptWithKek kek keyBytes) - writeFile ("keys/" <> getPathFromFileId (show $ fileSystemId inode) ++ ".iv") ivBytes + --createDirectoryIfMissing True $ "keys/" <> take 1 (show $ fileSystemId inode) + --writeFile ("keys/" <> getPathFromFileId (show $ fileSystemId inode) ++ ".key") (encryptWithKek kek keyBytes) + --writeFile ("keys/" <> getPathFromFileId (show $ fileSystemId inode) ++ ".iv") ivBytes + let encKey' = EncKey (fileSystemId inode) (encryptWithKek kek keyBytes) ivBytes - return (initCipher secretKey, initIV ivBytes) + return (return (initCipher secretKey, initIV ivBytes), encKey') -- this takes the encryption information and encrypts and moves the file after the response has been send makeFreeResource :: FileInfo -> Inode -> (AES256, IV AES256) -> IO () diff --git a/src/KeyStorage.hs b/src/KeyStorage.hs new file mode 100644 index 0000000..b1b3c0b --- /dev/null +++ b/src/KeyStorage.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +module KeyStorage where + +import ClassyPrelude.Yesod (MonadHandler, YesodPersist (YesodPersistBackend, runDB), return, ($)) +import Database.Persist (PersistStoreWrite (insertKey)) + +storeKey :: (MonadHandler m, YesodPersist site0, PersistStoreWrite (YesodPersistBackend site0), PersistStoreWrite (YesodPersistBackend site0)) => m () +storeKey = do + return () From aa678198377cfb133a87b9c7d906f5e72fa940a4 Mon Sep 17 00:00:00 2001 From: qvalentin Date: Sat, 25 Jun 2022 10:48:38 +0200 Subject: [PATCH 19/35] WIP: Cleanup mongo interaction --- src/DBModels.hs | 1 + src/Handler/Download.hs | 24 +++++++++++++++---- src/Handler/Upload.hs | 27 ++++++++++++++++++---- src/KeyStorage.hs | 51 +++++++++++++++++++++++++++++++++++++---- 4 files changed, 90 insertions(+), 13 deletions(-) diff --git a/src/DBModels.hs b/src/DBModels.hs index 7cb90f3..b4d875d 100644 --- a/src/DBModels.hs +++ b/src/DBModels.hs @@ -28,6 +28,7 @@ let mongoSettings = mkPersistSettings (ConT ''MongoContext) [mkPersist mongoSettings] [persistLowerCase| EncKey + Id String fsId String cipherKey ByteString cipherIv ByteString diff --git a/src/Handler/Download.hs b/src/Handler/Download.hs index 4fd4d4c..1be99fc 100644 --- a/src/Handler/Download.hs +++ b/src/Handler/Download.hs @@ -45,6 +45,8 @@ import ClassyPrelude tshow, unpack, void, + zip, + zipWith, ($), (++), (.), @@ -142,6 +144,7 @@ getDownloadR path = do runDB (selectFirst ([EncKeyFsId ==. (fileSystemId singleInode)]) ([])) >>= \case Nothing -> sendInternalError Just (Entity _ encKey) -> do + liftIO $ print encKey let key' = initCipher $ Key (decryptWithKek kek $ encKeyCipherKey encKey) :: AES256 respondSource (S8.pack $ fromMaybe "application/octet-stream" (mimeType singleInode)) $ retrieveFile singleInode @@ -150,9 +153,16 @@ getDownloadR path = do multipleInodes -> do let archiveName = fromMaybe "Files" Nothing addHeader "Content-Disposition" ("attachment; filename=\"" ++ decodeUtf8 archiveName ++ ".zip" ++ "\"") - (_, tempFile) <- allocate (makeAllocateResource kek multipleInodes) freeResource + mayBeEncKeys <- mapM (\singleInode -> runDB $ selectFirst ([EncKeyFsId ==. (fileSystemId singleInode)]) ([])) multipleInodes + encKeys <- mapM justOrInternalError mayBeEncKeys + let encKeysWithInodes = zip multipleInodes encKeys + (_, tempFile) <- allocate (makeAllocateResource kek encKeysWithInodes) freeResource sendFile "application/zip" tempFile +justOrInternalError :: MonadHandler m => Maybe a -> m a +justOrInternalError (Just a) = return a +justOrInternalError Nothing = sendInternalError + lookupPaths :: MonadHandler m => [Text] -> m [Path] lookupPaths parentPath = do maybeChildenParam <- lookupGetParam "children" @@ -160,16 +170,22 @@ lookupPaths parentPath = do Just inodeNames -> pure $ map (\name -> fromMultiPiece $ parentPath <> [name]) inodeNames Nothing -> pure [fromMultiPiece parentPath] -makeAllocateResource :: KeyEncryptionKey -> [Models.Inode.Inode] -> IO FilePath -makeAllocateResource kek inodes = do +makeAllocateResource :: KeyEncryptionKey -> [(Inode, Entity EncKey)] -> IO FilePath +makeAllocateResource kek encKeyEntites = do path <- emptySystemTempFile "FileFighterFileHandler.zip" - inodesWithKeys <- mapM (\inode -> fmap (inode,) (getKeyForInode kek inode)) inodes + let inodesWithKeys = map (\(inode, encKey) -> (inode, initEncKey encKey kek)) encKeyEntites createZip inodesWithKeys path return path freeResource :: FilePath -> IO () freeResource = removeFile +initEncKey :: Entity EncKey -> KeyEncryptionKey -> (AES256, IV AES256) +initEncKey (Entity _ encKey) kek = do + let key = initCipher $ Key (decryptWithKek kek $ encKeyCipherKey encKey) + let iv = (initIV $ encKeyCipherIv encKey) + (key, iv) + lookupRequiredInodeIds :: MonadHandler m => m String lookupRequiredInodeIds = do maybeIds <- lookupGetParam "ids" diff --git a/src/Handler/Upload.hs b/src/Handler/Upload.hs index 8b64b15..684cd30 100644 --- a/src/Handler/Upload.hs +++ b/src/Handler/Upload.hs @@ -9,12 +9,31 @@ -- | module Handler.Upload where -import ClassyPrelude hiding (Handler) +import ClassyPrelude + ( Applicative ((<*>)), + ByteString, + Eq ((/=)), + IO, + Integer, + IsSequence (filter), + Maybe (..), + Monad (return, (>>=)), + MonadIO (liftIO), + Monoid (mempty), + Show (show), + Text, + print, + singleton, + undefined, + ($), + (.), + (<$>), + ) import ClassyPrelude.Yesod ( ConduitT, FileInfo (fileContentType), MonadHandler (HandlerSite), - PersistStoreWrite (insert), + PersistStoreWrite (insertKey), RedirectUrl, RenderRoute (Route), Response (responseBody), @@ -32,7 +51,7 @@ import Crypto.Init import Crypto.KeyEncrptionKey hiding (initCipher, initIV) import Crypto.Random import Crypto.Types -import DBModels (EncKey (EncKey), EntityField (EncKeyId)) +import DBModels (EncKey (EncKey), EntityField (EncKeyId), Key (EncKeyKey)) import Data.Aeson ( Result (Error, Success), Value, @@ -93,7 +112,7 @@ postUploadR = do case filter filterFiles createdInodes of [singleInode] -> do (alloc, encKey') <- liftIO $ makeAllocateResource kek singleInode - runDB $ insert encKey' + runDB $ insertKey (EncKeyKey "dsa") encKey' (_, _) <- allocate alloc (makeFreeResource file singleInode) return responseBody _ -> sendInternalError diff --git a/src/KeyStorage.hs b/src/KeyStorage.hs index b1b3c0b..ca74ead 100644 --- a/src/KeyStorage.hs +++ b/src/KeyStorage.hs @@ -1,13 +1,54 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Redundant bracket" #-} -- | module KeyStorage where -import ClassyPrelude.Yesod (MonadHandler, YesodPersist (YesodPersistBackend, runDB), return, ($)) -import Database.Persist (PersistStoreWrite (insertKey)) +import ClassyPrelude (Handler, Maybe (Just, Nothing), MonadIO (liftIO), ReaderT, maybe, throwIO) +import ClassyPrelude.Yesod (ErrorResponse (NotFound), MonadHandler, PersistStoreRead (get), YesodPersist (YesodPersistBackend, runDB), return, ($)) +import Crypto.Cipher.AES (AES256) +import Crypto.Cipher.Types (IV) +import Crypto.Init (initCipher, initIV) +import Crypto.KeyEncrptionKey (KeyEncryptionKey, decryptWithKek) +import Crypto.Types (Key (Key)) +import DBModels (EncKey (EncKey, encKeyCipherIv, encKeyCipherKey), EntityField (EncKeyFsId), Key (EncKeyKey)) +import Database.Persist (Entity, PersistRecordBackend, PersistStoreWrite (insertKey)) +import Database.Persist.MongoDB (Entity (Entity), MongoContext, PersistQueryRead (selectFirst), docToEntityEither, (==.)) +import Foundation (App) +import Models.Inode (Inode (Inode, fileSystemId)) +import Utils.HandlerUtils (sendInternalError) +import Yesod.Core.Types (HandlerContents (HCError)) + +--storeKey :: (MonadHandler m, YesodPersist App, PersistStoreWrite (YesodPersistBackend App), PersistStoreWrite (YesodPersistBackend App), YesodPersist App) => m EncKey +--storeKey :: (MonadHandler m) => ReaderT MongoContext Handler App -> Handler a +--storeKey = do +--runDB $ get "" +--return () + +getEncKeyOrInternalError :: + (MonadHandler m, PersistRecordBackend (Entity EncKey) MongoContext, PersistQueryRead MongoContext) => + Inode -> + KeyEncryptionKey -> + ReaderT MongoContext m ((AES256, IV AES256)) +getEncKeyOrInternalError inode kek = do + mres :: (Maybe (Entity EncKey)) <- selectFirst [EncKeyFsId ==. fileSystemId inode] [] + case mres of + Nothing -> sendInternalError + Just (Entity _ encKey) -> do + let key = initCipher $ Key (decryptWithKek kek $ encKeyCipherKey encKey) + let iv = (initIV $ encKeyCipherIv encKey) + return (key, iv) -storeKey :: (MonadHandler m, YesodPersist site0, PersistStoreWrite (YesodPersistBackend site0), PersistStoreWrite (YesodPersistBackend site0)) => m () -storeKey = do - return () +storeEncKey :: + (MonadHandler m, PersistRecordBackend (Entity EncKey) MongoContext, PersistQueryRead MongoContext) => + Inode -> + EncKey -> + ReaderT MongoContext m () +storeEncKey inode encKey = do + insertKey (EncKeyKey (fileSystemId inode)) encKey From 393a7bd762b08851cf1614553a9cd14ce5d7d0f7 Mon Sep 17 00:00:00 2001 From: qvalentin Date: Sun, 3 Jul 2022 19:02:19 +0200 Subject: [PATCH 20/35] Finish mongo db queries, setup basic tests --- config/test-settings.yml | 14 ++++++ package.yaml | 12 +++++ src/Application.hs | 47 +++++++++++++++--- src/DBModels.hs | 1 - src/Foundation.hs | 4 +- src/Handler/Delete.hs | 3 ++ src/Handler/Download.hs | 55 +++++++++------------ src/Handler/Preview.hs | 99 ++++++++++++++++++++------------------ src/Handler/Upload.hs | 7 +-- src/KeyStorage.hs | 24 ++++++--- src/Models/Inode.hs | 15 +++++- src/Utils/HandlerUtils.hs | 69 ++++++++++++++------------ test/Handler/CommonSpec.hs | 3 ++ test/Handler/HomeSpec.hs | 17 +++++++ test/Spec.hs | 1 + test/TestImport.hs | 67 ++++++++++++++++++++++++++ 16 files changed, 307 insertions(+), 131 deletions(-) create mode 100644 config/test-settings.yml create mode 100644 test/Handler/CommonSpec.hs create mode 100644 test/Handler/HomeSpec.hs create mode 100644 test/Spec.hs create mode 100644 test/TestImport.hs diff --git a/config/test-settings.yml b/config/test-settings.yml new file mode 100644 index 0000000..13bd3c9 --- /dev/null +++ b/config/test-settings.yml @@ -0,0 +1,14 @@ +appProfile: "_env:APP_PROFILE:prod" + +fileSystemServiceSettings: + url: "_env:FILESYSTEMSERVICE_URL:localhost" + port: "_env:FILESYSTEMSERVICE_PORT:8080" + +encryptionPassword: "_env:ENCRYPTION_PASSWORD:changeThis" + +appDatabaseConf: + user: root + password: example + host: "localhost" + database: filehandler + connections: 10 diff --git a/package.yaml b/package.yaml index 5f0d3a2..6e4ba7a 100644 --- a/package.yaml +++ b/package.yaml @@ -35,12 +35,24 @@ dependencies: - persistent-mongoDB - mongoDB - template-haskell + - fast-logger # The library contains all of our application code. The executable # defined below is just a thin wrapper. library: source-dirs: src +# Test suite +tests: + yesodMongoTemplate-test: + main: Spec.hs + source-dirs: test + ghc-options: -Wall + dependencies: + - FileHandlerYesod + - hspec >=2.0.0 + - yesod-test + # Runnable executable for our application executables: FileHandlerYesod: diff --git a/src/Application.hs b/src/Application.hs index ac8ed41..5c85f0a 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -2,18 +2,25 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} -module Application where +module Application + ( appMain, + makeFoundation, + makeLogWare, + ) +where import ClassyPrelude ( Bool (False, True), + Eq ((==)), IO, Maybe (Just, Nothing), - Monad (return), + Monad (return, (>>=)), Num ((*)), const, ($), + (||), ) -import ClassyPrelude.Yesod (PersistConfig (createPoolConfig)) +import ClassyPrelude.Yesod (Default (def), PersistConfig (createPoolConfig)) import Crypto.KeyEncrptionKey (createKeyEncrptionKey, getOrCreateKekIV) import Data.Yaml.Config (loadYamlSettingsArgs, useEnv) import FileSystemServiceClient.FileSystemServiceClient (makeFileSystemServiceClient) @@ -37,7 +44,7 @@ import Handler.Health (getHealthR) import Handler.Home (getHomeR) import Handler.Preview (getPreviewR) import Handler.Upload (postUploadR) -import Network.Wai () +import Network.Wai (Middleware) import Network.Wai.Handler.Warp (run) import Network.Wai.Middleware.Cors ( CorsResourcePolicy @@ -53,12 +60,20 @@ import Network.Wai.Middleware.Cors ), cors, ) +import Network.Wai.Middleware.RequestLogger (Destination (Logger), IPAddrSource (FromFallback, FromSocket), OutputFormat (Apache, Detailed), RequestLoggerSettings (destination, outputFormat), mkRequestLogger) import Network.Wai.Parse () import Settings - ( AppSettings (appDatabaseConf, encryptionPassword, fileSystemServiceSettings), + ( AppSettings (appDatabaseConf, appProfile, encryptionPassword, fileSystemServiceSettings), configSettingsYmlValue, ) +import System.Log.FastLogger + ( defaultBufSize, + newStdoutLoggerSet, + toLogStr, + ) import Yesod.Core (mkYesodDispatch, toWaiApp) +import Yesod.Core.Types (Logger (loggerSet)) +import Yesod.Default.Config2 (makeYesodLogger) mkYesodDispatch "App" resourcesApp @@ -69,13 +84,33 @@ makeFoundation appSettings = do iv <- getOrCreateKekIV let keyEncrptionKey = createKeyEncrptionKey (encryptionPassword appSettings) iv appConnPool <- createPoolConfig $ appDatabaseConf appSettings + appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger return App { appSettings = appSettings, appConnPool = appConnPool, fileSystemServiceClient = fssC, - keyEncrptionKey = keyEncrptionKey + keyEncrptionKey = keyEncrptionKey, + appLogger = appLogger + } + +makeLogWare :: App -> IO Middleware +makeLogWare foundation = do + let profile = appProfile $ appSettings foundation + let nonProd = "stage" == profile || "dev" == profile + mkRequestLogger + def + { outputFormat = + if nonProd + then Detailed True + else + Apache + ( if nonProd + then FromFallback + else FromSocket + ), + destination = Logger $ loggerSet $ appLogger foundation } appMain :: IO () diff --git a/src/DBModels.hs b/src/DBModels.hs index b4d875d..3dea01f 100644 --- a/src/DBModels.hs +++ b/src/DBModels.hs @@ -29,7 +29,6 @@ let mongoSettings = mkPersistSettings (ConT ''MongoContext) [persistLowerCase| EncKey Id String - fsId String cipherKey ByteString cipherIv ByteString deriving Show diff --git a/src/Foundation.hs b/src/Foundation.hs index 7ce507a..89f19dc 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -24,13 +24,15 @@ import Yesod.Core mkYesodData, parseRoutesFile, ) +import Yesod.Core.Types import Yesod.Persist.Core (YesodPersist (..)) data App = App { appSettings :: AppSettings, appConnPool :: ConnectionPool, fileSystemServiceClient :: FileSystemServiceClient, - keyEncrptionKey :: KeyEncryptionKey + keyEncrptionKey :: KeyEncryptionKey, + appLogger :: Logger } mkYesodData "App" $(parseRoutesFile "routes.yesodroutes") diff --git a/src/Handler/Delete.hs b/src/Handler/Delete.hs index b6fb0eb..d9c7d8c 100644 --- a/src/Handler/Delete.hs +++ b/src/Handler/Delete.hs @@ -10,12 +10,14 @@ import qualified Data.Text as DataText import FileStorage (filterFiles, getPathFromFileId) import FileSystemServiceClient.FileSystemServiceClient import Foundation +import KeyStorage (deleteEncKey) import Models.Inode import Network.HTTP.Req import Network.HTTP.Types import System.Directory import Utils.HandlerUtils import Yesod.Core +import Yesod.Persist (YesodPersist (runDB)) import Prelude (filter) deleteDeleteR :: [Text] -> Handler Value @@ -25,6 +27,7 @@ deleteDeleteR path = do (responseBody, responseStatusCode, responseStatusMessage) <- liftIO $ deleteInode authToken path inodes <- handleApiCall responseBody responseStatusCode responseStatusMessage liftIO $ mapM_ deleteFile (filter filterFiles inodes) -- Todo: check if file exists + runDB $ mapM_ deleteEncKey inodes return responseBody deleteFile :: Inode -> IO () diff --git a/src/Handler/Download.hs b/src/Handler/Download.hs index 1be99fc..c195ac5 100644 --- a/src/Handler/Download.hs +++ b/src/Handler/Download.hs @@ -6,6 +6,8 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Unused LANGUAGE pragma" #-} + module Handler.Download where import ClassyPrelude @@ -61,6 +63,7 @@ import ClassyPrelude.Yesod MonadResource, PersistQueryRead (selectFirst), PersistUniqueRead (getBy), + ToJSON (toJSON), TypedContent, Value, YesodPersist (runDB), @@ -75,6 +78,7 @@ import ClassyPrelude.Yesod sendChunkBS, sendFile, sinkFile, + status400, yield, (.|), ) @@ -97,17 +101,20 @@ import FileSystemServiceClient.FileSystemServiceClient UploadedInode (parentPath), ) import Foundation (App (App, fileSystemServiceClient, keyEncrptionKey), Handler) +import KeyStorage (getEncKeyOrInternalError) import Models.Inode ( Inode (lastUpdated, mimeType, name, path, size), fileSystemId, + getFirstPathPiece, ) import Models.Path (Path, fromMultiPiece) +import Models.RestApiStatus (RestApiStatus (RestApiStatus)) import Network.HTTP.Req (responseStatusMessage) import qualified Network.HTTP.Types as HttpTypes import System.Directory (doesDirectoryExist, removeFile) import System.IO.Temp (emptySystemTempFile) import UnliftIO.Resource (allocate) -import Utils.HandlerUtils (handleApiCall, lookupAuth, sendInternalError) +import Utils.HandlerUtils (handleApiCall, handleApiCall', lookupAuth, sendErrorOrRedirect, sendInternalError) import Utils.ZipFile import Yesod.Routes.TH.Types (flatten) @@ -128,35 +135,24 @@ getDownloadR path = do paths inodes <- - concat - <$> mapM - ( \(responseBody, responseStatusCode, responseStatusMessage) -> do - handleApiCall responseBody responseStatusCode responseStatusMessage - ) - apiResponses + concat <$> mapM handleApiCall' apiResponses case inodes of + [] -> sendErrorOrRedirect status400 $ toJSON $ RestApiStatus "Can not download a empty folder." "Bad Request" [singleInode] -> do liftIO $ print $ size singleInode addHeader "Content-Disposition" $ pack ("attachment; filename=\"" ++ Models.Inode.name singleInode ++ "\"") addHeader "Content-Length" $ tshow $ size singleInode - --(key, iv) <- liftIO $ getKeyForInode kek singleInode - runDB (selectFirst ([EncKeyFsId ==. (fileSystemId singleInode)]) ([])) >>= \case - Nothing -> sendInternalError - Just (Entity _ encKey) -> do - liftIO $ print encKey - let key' = initCipher $ Key (decryptWithKek kek $ encKeyCipherKey encKey) :: AES256 - respondSource (S8.pack $ fromMaybe "application/octet-stream" (mimeType singleInode)) $ - retrieveFile singleInode - .| decryptConduit (key') (initIV $ encKeyCipherIv encKey) mempty - .| awaitForever sendChunkBS - multipleInodes -> do - let archiveName = fromMaybe "Files" Nothing - addHeader "Content-Disposition" ("attachment; filename=\"" ++ decodeUtf8 archiveName ++ ".zip" ++ "\"") - mayBeEncKeys <- mapM (\singleInode -> runDB $ selectFirst ([EncKeyFsId ==. (fileSystemId singleInode)]) ([])) multipleInodes - encKeys <- mapM justOrInternalError mayBeEncKeys - let encKeysWithInodes = zip multipleInodes encKeys - (_, tempFile) <- allocate (makeAllocateResource kek encKeysWithInodes) freeResource + (inode, (key, iv)) <- runDB $ getEncKeyOrInternalError singleInode kek + respondSource (S8.pack $ fromMaybe "application/octet-stream" (mimeType singleInode)) $ + retrieveFile singleInode + .| decryptConduit key iv mempty + .| awaitForever sendChunkBS + first : moreInodes -> do + let archiveName = getFirstPathPiece first + addHeader "Content-Disposition" ("attachment; filename=\"" ++ pack archiveName ++ ".zip" ++ "\"") + encKeysWithInodes <- mapM (\inode -> runDB $ getEncKeyOrInternalError inode kek) (first : moreInodes) + (_, tempFile) <- allocate (makeAllocateResource encKeysWithInodes) freeResource sendFile "application/zip" tempFile justOrInternalError :: MonadHandler m => Maybe a -> m a @@ -170,22 +166,15 @@ lookupPaths parentPath = do Just inodeNames -> pure $ map (\name -> fromMultiPiece $ parentPath <> [name]) inodeNames Nothing -> pure [fromMultiPiece parentPath] -makeAllocateResource :: KeyEncryptionKey -> [(Inode, Entity EncKey)] -> IO FilePath -makeAllocateResource kek encKeyEntites = do +makeAllocateResource :: [(Inode, (AES256, IV AES256))] -> IO FilePath +makeAllocateResource inodesWithKeys = do path <- emptySystemTempFile "FileFighterFileHandler.zip" - let inodesWithKeys = map (\(inode, encKey) -> (inode, initEncKey encKey kek)) encKeyEntites createZip inodesWithKeys path return path freeResource :: FilePath -> IO () freeResource = removeFile -initEncKey :: Entity EncKey -> KeyEncryptionKey -> (AES256, IV AES256) -initEncKey (Entity _ encKey) kek = do - let key = initCipher $ Key (decryptWithKek kek $ encKeyCipherKey encKey) - let iv = (initIV $ encKeyCipherIv encKey) - (key, iv) - lookupRequiredInodeIds :: MonadHandler m => m String lookupRequiredInodeIds = do maybeIds <- lookupGetParam "ids" diff --git a/src/Handler/Preview.hs b/src/Handler/Preview.hs index 9844bbf..1739a76 100644 --- a/src/Handler/Preview.hs +++ b/src/Handler/Preview.hs @@ -1,63 +1,70 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} module Handler.Preview where +import ClassyPrelude + ( Bool (True), + Int, + MonadIO (liftIO), + Monoid (mempty), + Show (show), + String, + Text, + fromMaybe, + intercalate, + map, + print, + ($), + (.), + (<>), + ) import ClassyPrelude.Yesod - ( ($), - Show(show), - Int, - getYesod, - (.|), - MonadIO(liftIO), - String, - fromMaybe, - awaitForever, - respondSource, - sendChunkBS, - TypedContent, badRequest400, status400, ToJSON (toJSON) ) + ( Int, + MonadIO (liftIO), + Show (show), + String, + ToJSON (toJSON), + TypedContent, + YesodPersist (runDB), + awaitForever, + badRequest400, + fromMaybe, + getYesod, + respondSource, + sendChunkBS, + status400, + ($), + (.|), + ) +import Crypto.CryptoConduit +import Crypto.KeyEncrptionKey (getKeyForInode) import qualified Data.ByteString.Char8 as S8 -import FileStorage (retrieveFile, filterFiles) +import FileStorage (filterFiles, retrieveFile) +import FileSystemServiceClient.FileSystemServiceClient (FileSystemServiceClient (getInodeContent)) +import FileSystemServiceClient.FileSystemServiceClient hiding (mimeType) import Foundation +import KeyStorage (getEncKeyOrInternalError) import Models.Inode - - -import Utils.HandlerUtils - ( lookupAuth, handleApiCall, sendErrorOrRedirect ) -import FileSystemServiceClient.FileSystemServiceClient hiding (mimeType) -import Crypto.KeyEncrptionKey ( getKeyForInode ) -import ClassyPrelude - ( ($), - Show(show), - Monoid(mempty), - Int, - fromMaybe, - MonadIO(liftIO), - String, - Text, - (.), - print, - Bool(True), - intercalate, - (<>), - map ) -import Crypto.CryptoConduit -import FileSystemServiceClient.FileSystemServiceClient (FileSystemServiceClient(getInodeContent)) -import Models.RestApiStatus (RestApiStatus(RestApiStatus)) import Models.Path (fromMultiPiece) +import Models.RestApiStatus (RestApiStatus (RestApiStatus)) +import Utils.HandlerUtils + ( handleApiCall, + lookupAuth, + sendErrorOrRedirect, + ) -getPreviewR :: [Text] -> Handler TypedContent +getPreviewR :: [Text] -> Handler TypedContent getPreviewR path = do App {fileSystemServiceClient = FileSystemServiceClient {getInodeContent = getInodeContent'}, keyEncrptionKey = kek} <- getYesod bearerToken <- lookupAuth - (responseBody', responseStatusCode, responseStatusMessage) <- liftIO $ getInodeContent' bearerToken $ fromMultiPiece path inodes <- handleApiCall responseBody' responseStatusCode responseStatusMessage - case map (\i -> (i,filterFiles i))inodes of - [(inode,True)] -> do - (key, iv) <- liftIO $ getKeyForInode kek inode + case map (\i -> (i, filterFiles i)) inodes of + [(inode, True)] -> do + (inode, (key, iv)) <- runDB $ getEncKeyOrInternalError inode kek respondSource (S8.pack $ fromMaybe "application/octet-stream" (mimeType inode)) $ retrieveFile inode - .| decryptConduit key iv mempty - .| awaitForever sendChunkBS - _ -> sendErrorOrRedirect status400 $ toJSON $ RestApiStatus "Can not preview a folder." "Bad Request" + .| decryptConduit key iv mempty + .| awaitForever sendChunkBS + _ -> sendErrorOrRedirect status400 $ toJSON $ RestApiStatus "Can not preview a folder." "Bad Request" diff --git a/src/Handler/Upload.hs b/src/Handler/Upload.hs index 684cd30..f7f0c3f 100644 --- a/src/Handler/Upload.hs +++ b/src/Handler/Upload.hs @@ -69,6 +69,7 @@ import FileSystemServiceClient.FileSystemServiceClient UploadedInode (UploadedInode), ) import Foundation (App (App, fileSystemServiceClient, keyEncrptionKey), Handler) +import KeyStorage (getEncKeyOrInternalError, storeEncKey) import Models.Inode (Inode (fileSystemId)) import Models.Path (Path (Path)) import Network.HTTP.Types (Status (Status)) @@ -112,7 +113,7 @@ postUploadR = do case filter filterFiles createdInodes of [singleInode] -> do (alloc, encKey') <- liftIO $ makeAllocateResource kek singleInode - runDB $ insertKey (EncKeyKey "dsa") encKey' + runDB $ storeEncKey singleInode encKey' (_, _) <- allocate alloc (makeFreeResource file singleInode) return responseBody _ -> sendInternalError @@ -158,11 +159,7 @@ makeAllocateResource kek inode = do secretKey :: Crypto.Types.Key AES256 ByteString <- genSecretKey (undefined :: AES256) 32 let Key keyBytes = secretKey ivBytes <- genRandomIV (undefined :: AES256) - --createDirectoryIfMissing True $ "keys/" <> take 1 (show $ fileSystemId inode) - --writeFile ("keys/" <> getPathFromFileId (show $ fileSystemId inode) ++ ".key") (encryptWithKek kek keyBytes) - --writeFile ("keys/" <> getPathFromFileId (show $ fileSystemId inode) ++ ".iv") ivBytes let encKey' = EncKey (fileSystemId inode) (encryptWithKek kek keyBytes) ivBytes - return (return (initCipher secretKey, initIV ivBytes), encKey') -- this takes the encryption information and encrypts and moves the file after the response has been send diff --git a/src/KeyStorage.hs b/src/KeyStorage.hs index ca74ead..ec6b529 100644 --- a/src/KeyStorage.hs +++ b/src/KeyStorage.hs @@ -17,9 +17,9 @@ import Crypto.Cipher.Types (IV) import Crypto.Init (initCipher, initIV) import Crypto.KeyEncrptionKey (KeyEncryptionKey, decryptWithKek) import Crypto.Types (Key (Key)) -import DBModels (EncKey (EncKey, encKeyCipherIv, encKeyCipherKey), EntityField (EncKeyFsId), Key (EncKeyKey)) +import DBModels (EncKey (EncKey, encKeyCipherIv, encKeyCipherKey), Key (EncKeyKey)) import Database.Persist (Entity, PersistRecordBackend, PersistStoreWrite (insertKey)) -import Database.Persist.MongoDB (Entity (Entity), MongoContext, PersistQueryRead (selectFirst), docToEntityEither, (==.)) +import Database.Persist.MongoDB (Entity (Entity), MongoContext, PersistQueryRead (selectFirst), PersistStoreWrite (delete), docToEntityEither, (==.)) import Foundation (App) import Models.Inode (Inode (Inode, fileSystemId)) import Utils.HandlerUtils (sendInternalError) @@ -32,23 +32,31 @@ import Yesod.Core.Types (HandlerContents (HCError)) --return () getEncKeyOrInternalError :: - (MonadHandler m, PersistRecordBackend (Entity EncKey) MongoContext, PersistQueryRead MongoContext) => + (MonadHandler m, PersistRecordBackend EncKey MongoContext, PersistQueryRead MongoContext) => Inode -> KeyEncryptionKey -> - ReaderT MongoContext m ((AES256, IV AES256)) + ReaderT MongoContext m (Inode, (AES256, IV AES256)) getEncKeyOrInternalError inode kek = do - mres :: (Maybe (Entity EncKey)) <- selectFirst [EncKeyFsId ==. fileSystemId inode] [] + --mres :: (Maybe (Entity EncKey)) <- selectFirst [EncKeyFsId ==. fileSystemId inode] [] + mres :: (Maybe (EncKey)) <- get $ EncKeyKey (fileSystemId inode) case mres of Nothing -> sendInternalError - Just (Entity _ encKey) -> do + Just (encKey) -> do let key = initCipher $ Key (decryptWithKek kek $ encKeyCipherKey encKey) let iv = (initIV $ encKeyCipherIv encKey) - return (key, iv) + return (inode, (key, iv)) storeEncKey :: - (MonadHandler m, PersistRecordBackend (Entity EncKey) MongoContext, PersistQueryRead MongoContext) => + (MonadHandler m, PersistRecordBackend EncKey MongoContext, PersistQueryRead MongoContext) => Inode -> EncKey -> ReaderT MongoContext m () storeEncKey inode encKey = do insertKey (EncKeyKey (fileSystemId inode)) encKey + +deleteEncKey :: + (MonadHandler m, PersistRecordBackend EncKey MongoContext, PersistQueryRead MongoContext) => + Inode -> + ReaderT MongoContext m () +deleteEncKey inode = do + delete (EncKeyKey $ fileSystemId inode) diff --git a/src/Models/Inode.hs b/src/Models/Inode.hs index 2a6f650..e3a784b 100644 --- a/src/Models/Inode.hs +++ b/src/Models/Inode.hs @@ -1,11 +1,16 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Redundant bracket" #-} module Models.Inode where import ClassyPrelude import Data.Aeson -import Models.User +import Data.Text as T (pack, splitOn, unpack) import Models.Path (Path) +import Models.User data Inode = Inode { fileSystemId :: String, @@ -30,3 +35,11 @@ instance FromJSON Inode where { fieldLabelModifier = typeFieldRename, omitNothingFields = True } + +getFirstPathPiece :: Inode -> String +getFirstPathPiece inode = do + let inodePath = path inode + let path = T.pack $ fromMaybe (name inode) (inodePath) + case (filter (/= "") $ splitOn "/" path) of + [] -> name inode + firstPathPiece : rest -> T.unpack firstPathPiece diff --git a/src/Utils/HandlerUtils.hs b/src/Utils/HandlerUtils.hs index e35170b..1a5b425 100644 --- a/src/Utils/HandlerUtils.hs +++ b/src/Utils/HandlerUtils.hs @@ -7,41 +7,50 @@ module Utils.HandlerUtils where import ClassyPrelude - ( otherwise, - ($), - Monad(return, (>>=)), - Ord((<), (<=)), - Bool(..), - Int, - (<$>), - ByteString, - Text, - (&&), - maybe, - (.), - elem, - pack, - Utf8(decodeUtf8), MonadIO (liftIO), print, putStr, putStrLn ) + ( Bool (..), + ByteString, + Int, + Monad (return, (>>=)), + MonadIO (liftIO), + Ord ((<), (<=)), + Text, + Utf8 (decodeUtf8), + elem, + maybe, + otherwise, + pack, + print, + putStr, + putStrLn, + ($), + (&&), + (.), + (<$>), + ) import Data.Aeson import Foundation import Models.RestApiStatus import Network.HTTP.Types import Network.Wai (rawPathInfo) import Yesod - ( sendResponseStatus, - notAuthenticated, - MonadHandler(HandlerSite), - getRequest, - lookupCookie, - lookupGetParam, - redirect, - RedirectUrl, - ContentType, - YesodRequest(reqWaiRequest, reqAccept) ) + ( ContentType, + MonadHandler (HandlerSite), + RedirectUrl, + YesodRequest (reqAccept, reqWaiRequest), + getRequest, + lookupCookie, + lookupGetParam, + notAuthenticated, + redirect, + sendResponseStatus, + ) sendInternalError :: MonadHandler m => m a sendInternalError = sendResponseStatus (Status 500 "Internal Server Error.") $ toJSON $ RestApiStatus "Internal Server Error" "500" +handleApiCall' :: (MonadHandler m, FromJSON a, RedirectUrl (HandlerSite m) (Route App, [(Text, Text)])) => (Value, Int, ByteString) -> m a +handleApiCall' (body, statusCode, statusMessage) = handleApiCall body statusCode statusMessage + handleApiCall :: (MonadHandler m, FromJSON a, RedirectUrl (HandlerSite m) (Route App, [(Text, Text)])) => Value -> Int -> ByteString -> m a handleApiCall body statusCode statusMessage | 200 <= statusCode && statusCode < 299 = @@ -49,14 +58,14 @@ handleApiCall body statusCode statusMessage Success value -> return value Error e -> do - liftIO $ print e + liftIO $ print e sendInternalError | 400 <= statusCode && statusCode < 500 = do - liftIO $ print "4XX domain error" - sendErrorOrRedirect (Status statusCode statusMessage) body --sendResponseStatus (Status statusCode statusMessage) body + liftIO $ print "4XX domain error" + sendErrorOrRedirect (Status statusCode statusMessage) body --sendResponseStatus (Status statusCode statusMessage) body | otherwise = do - liftIO $ print body - sendInternalError + liftIO $ print body + sendInternalError sendErrorOrRedirect :: (MonadHandler m, RedirectUrl (HandlerSite m) (Route App, [(Text, Text)])) => Status -> Value -> m a sendErrorOrRedirect status body = diff --git a/test/Handler/CommonSpec.hs b/test/Handler/CommonSpec.hs new file mode 100644 index 0000000..b885a0f --- /dev/null +++ b/test/Handler/CommonSpec.hs @@ -0,0 +1,3 @@ +module Handler.CommonSpec where + +import TestImport diff --git a/test/Handler/HomeSpec.hs b/test/Handler/HomeSpec.hs new file mode 100644 index 0000000..fb7f35a --- /dev/null +++ b/test/Handler/HomeSpec.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Handler.HomeSpec (spec) where + +import TestImport + +spec :: Spec +spec = withApp $ do + describe "root endpoint" $ do + it "accepts get request and denies post request" $ do + get HomeR + statusIs 200 + request $ do + setMethod "POST" + setUrl HomeR + statusIs 405 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000..a824f8c --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/TestImport.hs b/test/TestImport.hs new file mode 100644 index 0000000..8a997a7 --- /dev/null +++ b/test/TestImport.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module TestImport + ( module TestImport, + module X, + ) +where + +-- Wiping the test database + +import Application +import ClassyPrelude as X hiding (Handler, delete, deleteBy) +import qualified Control.Monad.Fail +import Database.MongoDB.Admin (dropCollection) +import Database.MongoDB.Query (allCollections) +import Database.Persist as X hiding (get) +import Database.Persist.MongoDB hiding (master) +import Foundation as X +import Settings (appDatabaseConf) +import Test.Hspec as X +import Yesod.Core.Unsafe (fakeHandlerGetLogger) +import Yesod.Default.Config2 (loadYamlSettings, useEnv) +import Yesod.Test as X + +runDB :: Action IO a -> YesodExample App a +runDB query = do + app <- getTestYesod + liftIO $ runDBWithApp app query + +runDBWithApp :: App -> Action IO a -> IO a +runDBWithApp app query = do + liftIO $ + runMongoDBPool + (mgAccessMode $ appDatabaseConf $ appSettings app) + query + (appConnPool app) + +runHandler :: Handler a -> YesodExample App a +runHandler handler = do + app <- getTestYesod + fakeHandlerGetLogger appLogger app handler + +withApp :: SpecWith (TestApp App) -> Spec +withApp = before $ do + settings <- + loadYamlSettings + ["config/test-settings.yml", "config/settings.yml"] + [] + useEnv + foundation <- makeFoundation settings + wipeDB foundation + logWare <- liftIO $ makeLogWare foundation + return (foundation, logWare) + +-- This function will wipe your database. +-- 'withApp' calls it before each test, creating a clean environment for each +-- spec to run in. +wipeDB :: App -> IO () +wipeDB app = void $ runDBWithApp app dropAllCollections + +dropAllCollections :: (MonadIO m, Control.Monad.Fail.MonadFail m) => Action m [Bool] +dropAllCollections = allCollections >>= return . filter (not . isSystemCollection) >>= mapM dropCollection + where + isSystemCollection = isPrefixOf "system." From 2e7f6feee23ad9bd1b8877c5c4729bb4f0c4f83f Mon Sep 17 00:00:00 2001 From: qvalentin Date: Sun, 24 Jul 2022 18:20:16 +0200 Subject: [PATCH 21/35] some tests and confirm write to db --- src/Crypto/KeyEncrptionKey.hs | 15 +++---- src/Crypto/{Random.hs => RandomGen.hs} | 22 ++++++---- src/Handler/Download.hs | 4 +- src/Handler/Home.hs | 2 - src/Handler/Upload.hs | 4 +- src/KeyStorage.hs | 14 +++---- test/Crypto/CryptoConduitSpec.hs | 54 +++++++++++++++++++++++++ test/Handler/CommonSpec.hs | 9 ++++- test/TestImport.hs | 2 +- test/resources/iv | 1 + test/resources/key | Bin 0 -> 32 bytes 11 files changed, 93 insertions(+), 34 deletions(-) rename src/Crypto/{Random.hs => RandomGen.hs} (81%) create mode 100644 test/Crypto/CryptoConduitSpec.hs create mode 100644 test/resources/iv create mode 100644 test/resources/key diff --git a/src/Crypto/KeyEncrptionKey.hs b/src/Crypto/KeyEncrptionKey.hs index 7e2b030..f5dad65 100644 --- a/src/Crypto/KeyEncrptionKey.hs +++ b/src/Crypto/KeyEncrptionKey.hs @@ -11,14 +11,14 @@ import Crypto.Cipher.AES import Crypto.Cipher.Types import Crypto.Data.Padding import Crypto.Error +import Crypto.Init (initCipher, initIV) import Crypto.KDF.BCryptPBKDF (Parameters (Parameters), generate) -import Crypto.Random (genRandomIV) +import Crypto.RandomGen (genRandomIV) import Crypto.Types (Key (Key)) import Data.ByteArray -import System.Directory (doesFileExist) -import Models.Inode import FileStorage (getPathFromFileId) -import Crypto.Init (initCipher, initIV) +import Models.Inode +import System.Directory (doesFileExist) kekSalt :: ByteString kekSalt = "FileFighterFileHandlerWithSomeSalt" @@ -28,7 +28,6 @@ data KeyEncryptionKey = KeyEncryptionKey initialIV :: IV AES256 } - -- This should use the database later getOrCreateKekIV :: IO ByteString getOrCreateKekIV = do @@ -48,7 +47,7 @@ createKeyEncrptionKey password ivBytes = do Just initIV -> do let secretKey :: Key AES256 ByteString = Key $ generateKeyfromPassword (fromString password) KeyEncryptionKey - { blockCipher = initCipher secretKey , + { blockCipher = initCipher secretKey, initialIV = initIV } @@ -68,9 +67,7 @@ decryptWithKek r@KeyEncryptionKey {blockCipher = cipher, initialIV = iv} message decrypted (unpad (PKCS7 (blockSize cipher)) decrypted) - - -getKeyForInode :: KeyEncryptionKey -> Inode -> IO (AES256, IV AES256) +getKeyForInode :: KeyEncryptionKey -> Inode -> IO (AES256, IV AES256) getKeyForInode kek inode = do key <- decryptWithKek kek <$> readFile ("keys/" <> getPathFromFileId (show $ fileSystemId inode) ++ ".key") iv <- readFile ("keys/" <> getPathFromFileId (show $ fileSystemId inode) ++ ".iv") diff --git a/src/Crypto/Random.hs b/src/Crypto/RandomGen.hs similarity index 81% rename from src/Crypto/Random.hs rename to src/Crypto/RandomGen.hs index 7b0b46b..c943ea1 100644 --- a/src/Crypto/Random.hs +++ b/src/Crypto/RandomGen.hs @@ -1,21 +1,27 @@ --- | {-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-deprecations #-} -module Crypto.Random where +-- | +module Crypto.RandomGen where + import ClassyPrelude -import Crypto.Random.Types import Crypto.Cipher.Types -import Data.ByteArray +import Crypto.Random.Types import Crypto.Types (Key (Key)) +import Data.ByteArray -- | Generates a string of bytes (key) of a specific length for a given block cipher -genSecretKey :: forall m c a. (MonadRandom m, BlockCipher c, ByteArray a) => c -- ^ - -> Int -- ^ - -> m (Key c a) +genSecretKey :: + forall m c a. + (MonadRandom m, BlockCipher c, ByteArray a) => + -- | + c -> + -- | + Int -> + m (Key c a) genSecretKey _ = fmap Key . getRandomBytes -- | Generate a random initialization vector for a given block cipher diff --git a/src/Handler/Download.hs b/src/Handler/Download.hs index c195ac5..f4b3953 100644 --- a/src/Handler/Download.hs +++ b/src/Handler/Download.hs @@ -88,7 +88,7 @@ import Crypto.CryptoConduit (decryptConduit) import Crypto.Init import Crypto.KeyEncrptionKey (KeyEncryptionKey, decryptWithKek, getKeyForInode) import Crypto.Types (Key (Key)) -import DBModels (EncKey (EncKey, encKeyCipherIv, encKeyCipherKey), EntityField (EncKeyFsId, EncKeyId)) +import DBModels (EncKey (EncKey, encKeyCipherIv, encKeyCipherKey)) import qualified Data.ByteString.Char8 as S8 import Data.Text (splitAt, splitOn) import Database.Persist (PersistQueryRead (selectKeysRes), (==.)) @@ -141,9 +141,9 @@ getDownloadR path = do [] -> sendErrorOrRedirect status400 $ toJSON $ RestApiStatus "Can not download a empty folder." "Bad Request" [singleInode] -> do liftIO $ print $ size singleInode + (inode, (key, iv)) <- runDB $ getEncKeyOrInternalError singleInode kek addHeader "Content-Disposition" $ pack ("attachment; filename=\"" ++ Models.Inode.name singleInode ++ "\"") addHeader "Content-Length" $ tshow $ size singleInode - (inode, (key, iv)) <- runDB $ getEncKeyOrInternalError singleInode kek respondSource (S8.pack $ fromMaybe "application/octet-stream" (mimeType singleInode)) $ retrieveFile singleInode .| decryptConduit key iv mempty diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 688f7fa..ed76aab 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -11,6 +11,4 @@ import Yesod.Core getHomeR :: Handler String getHomeR = do - let encKey' = EncKey "" "" - --runDB $ insertKey (EncKeyKey' "das") encKey' return "root Endpoint of the FileHandler Api, you should not have got here." diff --git a/src/Handler/Upload.hs b/src/Handler/Upload.hs index f7f0c3f..bce10a7 100644 --- a/src/Handler/Upload.hs +++ b/src/Handler/Upload.hs @@ -49,7 +49,7 @@ import Crypto.CryptoConduit (encryptConduit) import Crypto.Error import Crypto.Init import Crypto.KeyEncrptionKey hiding (initCipher, initIV) -import Crypto.Random +import Crypto.RandomGen import Crypto.Types import DBModels (EncKey (EncKey), EntityField (EncKeyId), Key (EncKeyKey)) import Data.Aeson @@ -159,7 +159,7 @@ makeAllocateResource kek inode = do secretKey :: Crypto.Types.Key AES256 ByteString <- genSecretKey (undefined :: AES256) 32 let Key keyBytes = secretKey ivBytes <- genRandomIV (undefined :: AES256) - let encKey' = EncKey (fileSystemId inode) (encryptWithKek kek keyBytes) ivBytes + let encKey' = EncKey (encryptWithKek kek keyBytes) ivBytes return (return (initCipher secretKey, initIV ivBytes), encKey') -- this takes the encryption information and encrypts and moves the file after the response has been send diff --git a/src/KeyStorage.hs b/src/KeyStorage.hs index ec6b529..574bda0 100644 --- a/src/KeyStorage.hs +++ b/src/KeyStorage.hs @@ -25,19 +25,12 @@ import Models.Inode (Inode (Inode, fileSystemId)) import Utils.HandlerUtils (sendInternalError) import Yesod.Core.Types (HandlerContents (HCError)) ---storeKey :: (MonadHandler m, YesodPersist App, PersistStoreWrite (YesodPersistBackend App), PersistStoreWrite (YesodPersistBackend App), YesodPersist App) => m EncKey ---storeKey :: (MonadHandler m) => ReaderT MongoContext Handler App -> Handler a ---storeKey = do ---runDB $ get "" ---return () - getEncKeyOrInternalError :: (MonadHandler m, PersistRecordBackend EncKey MongoContext, PersistQueryRead MongoContext) => Inode -> KeyEncryptionKey -> ReaderT MongoContext m (Inode, (AES256, IV AES256)) getEncKeyOrInternalError inode kek = do - --mres :: (Maybe (Entity EncKey)) <- selectFirst [EncKeyFsId ==. fileSystemId inode] [] mres :: (Maybe (EncKey)) <- get $ EncKeyKey (fileSystemId inode) case mres of Nothing -> sendInternalError @@ -47,12 +40,15 @@ getEncKeyOrInternalError inode kek = do return (inode, (key, iv)) storeEncKey :: - (MonadHandler m, PersistRecordBackend EncKey MongoContext, PersistQueryRead MongoContext) => + (MonadIO m, PersistRecordBackend EncKey MongoContext) => Inode -> EncKey -> ReaderT MongoContext m () storeEncKey inode encKey = do - insertKey (EncKeyKey (fileSystemId inode)) encKey + let dbKey = EncKeyKey (fileSystemId inode) + insertKey dbKey encKey + get dbKey + return () deleteEncKey :: (MonadHandler m, PersistRecordBackend EncKey MongoContext, PersistQueryRead MongoContext) => diff --git a/test/Crypto/CryptoConduitSpec.hs b/test/Crypto/CryptoConduitSpec.hs new file mode 100644 index 0000000..f7d4146 --- /dev/null +++ b/test/Crypto/CryptoConduitSpec.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-deprecations #-} + +-- | +module Crypto.CryptoConduitSpec where + +import ClassyPrelude.Conduit (foldC, runConduitRes, (.|)) +import ClassyPrelude.Yesod (yield) +import Crypto.Cipher.AES (AES256) +import Crypto.Cipher.Types (IV) +import Crypto.CryptoConduit (decryptConduit, encryptConduit) +import Crypto.Init (initCipher, initIV) +import Crypto.RandomGen (genRandomIV, genSecretKey) +import Crypto.Types (Key (Key)) +import TestImport + ( ByteString, + Monoid (mempty), + Spec, + describe, + it, + readFile, + shouldBe, + shouldNotBe, + undefined, + ($), + ) + +spec :: Spec +spec = do + describe "CryptoConduit" $ do + it "Encrypts and decrypts the message with random iv and key" $ do + secretKey :: Crypto.Types.Key AES256 ByteString <- genSecretKey (undefined :: AES256) 32 + ivBytes <- genRandomIV (undefined :: AES256) + let key = initCipher secretKey + let iv :: IV AES256 = initIV ivBytes + let message = "hallo" + result <- runConduitRes $ yield message .| encryptConduit key iv mempty .| decryptConduit key iv mempty .| foldC + result `shouldBe` message + encrypted <- runConduitRes $ yield message .| encryptConduit key iv mempty .| foldC + encrypted `shouldNotBe` message + + it "Encrypted and decrypts the message with give iv and key" $ do + keyBytes <- readFile "./test/resources/key" + ivBytes <- readFile "./test/resources/iv" + let key :: AES256 = initCipher (Key keyBytes) + let iv :: IV AES256 = initIV ivBytes + let message = "hallo" + result <- runConduitRes $ yield message .| encryptConduit key iv mempty .| decryptConduit key iv mempty .| foldC + result `shouldBe` message + encrypted <- runConduitRes $ yield message .| encryptConduit key iv mempty .| foldC + encrypted `shouldNotBe` message + encrypted `shouldBe` "\162Pu\DC3\168\170\161 '\157\SYNQ:\149W\203" diff --git a/test/Handler/CommonSpec.hs b/test/Handler/CommonSpec.hs index b885a0f..7730858 100644 --- a/test/Handler/CommonSpec.hs +++ b/test/Handler/CommonSpec.hs @@ -1,3 +1,10 @@ -module Handler.CommonSpec where +module Handler.CommonSpec (spec) where import TestImport + +spec :: Spec +spec = withApp $ do + describe "home endpoint" $ do + it "gives a 200" $ do + get HomeR + statusIs 200 diff --git a/test/TestImport.hs b/test/TestImport.hs index 8a997a7..d9d4c46 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -51,7 +51,7 @@ withApp = before $ do [] useEnv foundation <- makeFoundation settings - wipeDB foundation + --wipeDB foundation logWare <- liftIO $ makeLogWare foundation return (foundation, logWare) diff --git a/test/resources/iv b/test/resources/iv new file mode 100644 index 0000000..340744a --- /dev/null +++ b/test/resources/iv @@ -0,0 +1 @@ +ÐÍR1[ %X¿À›¥ÄÇ \ No newline at end of file diff --git a/test/resources/key b/test/resources/key new file mode 100644 index 0000000000000000000000000000000000000000..17cca1aee5501ec4e5d58d3e9c6735d778451b0e GIT binary patch literal 32 ocmdPoy{lXz{;=5n=;m|bYP03l)nD}g`)R^p8ZIlZ=3~+V0Nx=CyZ`_I literal 0 HcmV?d00001 From f3c6cea98c26df27570614b51fa9f0c7b217b6dc Mon Sep 17 00:00:00 2001 From: qvalentin Date: Mon, 26 Sep 2022 09:42:50 +0200 Subject: [PATCH 22/35] Make using encrption configurable --- config/settings.yml | 4 +- src/Application.hs | 21 +++++- src/ConduitHelper.hs | 7 ++ src/Crypto/CryptoConduit.hs | 144 ++++++++++++++++++++---------------- src/Foundation.hs | 2 +- src/Handler/Download.hs | 28 ++++--- src/Handler/Preview.hs | 6 +- src/Handler/Upload.hs | 32 +++++--- src/KeyStorage.hs | 22 ++++-- src/Settings.hs | 2 +- src/Utils/ZipFile.hs | 23 +++--- 11 files changed, 178 insertions(+), 113 deletions(-) create mode 100644 src/ConduitHelper.hs diff --git a/config/settings.yml b/config/settings.yml index 13bd3c9..ea7efa8 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -4,11 +4,11 @@ fileSystemServiceSettings: url: "_env:FILESYSTEMSERVICE_URL:localhost" port: "_env:FILESYSTEMSERVICE_PORT:8080" -encryptionPassword: "_env:ENCRYPTION_PASSWORD:changeThis" +encryptionPassword: "_env:ENCRYPTION_PASSWORD:changeThis" # set this to null to not use encryptio appDatabaseConf: user: root password: example host: "localhost" database: filehandler - connections: 10 + connections: 9 diff --git a/src/Application.hs b/src/Application.hs index 5c85f0a..b10ff6e 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -10,14 +10,21 @@ module Application where import ClassyPrelude - ( Bool (False, True), - Eq ((==)), + ( Applicative ((<*>)), + Bool (False, True), + Eq ((/=), (==)), + Functor (fmap), IO, Maybe (Just, Nothing), Monad (return, (>>=)), Num ((*)), const, + isJust, + map, + print, + when, ($), + (<$>), (||), ) import ClassyPrelude.Yesod (Default (def), PersistConfig (createPoolConfig)) @@ -81,8 +88,14 @@ makeFoundation :: AppSettings -> IO App makeFoundation appSettings = do let fssC = makeFileSystemServiceClient (fileSystemServiceSettings appSettings) - iv <- getOrCreateKekIV - let keyEncrptionKey = createKeyEncrptionKey (encryptionPassword appSettings) iv + let maybeEncryptionPassword = case encryptionPassword appSettings of + Just "null" -> Nothing + Nothing -> Nothing + Just password -> Just password + + print maybeEncryptionPassword + iv <- if isJust $ maybeEncryptionPassword then getOrCreateKekIV else return "FallBackIV" + let keyEncrptionKey = createKeyEncrptionKey <$> maybeEncryptionPassword <*> Just iv appConnPool <- createPoolConfig $ appDatabaseConf appSettings appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger diff --git a/src/ConduitHelper.hs b/src/ConduitHelper.hs new file mode 100644 index 0000000..c1f4e90 --- /dev/null +++ b/src/ConduitHelper.hs @@ -0,0 +1,7 @@ +-- | +module ConduitHelper where + +import ClassyPrelude.Conduit + +idC :: MonadIO m => ConduitT b b m () +idC = takeWhileC (const True) diff --git a/src/Crypto/CryptoConduit.hs b/src/Crypto/CryptoConduit.hs index 7569fa2..302fda3 100644 --- a/src/Crypto/CryptoConduit.hs +++ b/src/Crypto/CryptoConduit.hs @@ -2,74 +2,92 @@ {-# LANGUAGE OverloadedStrings #-} -- | - module Crypto.CryptoConduit where + import ClassyPrelude - ( ($), - Integral(div), - Monad((>>=), return), - Num((-), (+), (*)), - Ord(max), - Semigroup((<>)), - Maybe(Just, Nothing), - maybe, - fromMaybe, - IsSequence(drop, splitAt), - MonadIO, - ByteString, - error, - length, - null, - (.) ) + ( ByteString, + Integral (div), + IsSequence (drop, splitAt), + Maybe (Just, Nothing), + Monad (return, (>>=)), + MonadIO, + Num ((*), (+), (-)), + Ord (max), + Semigroup ((<>)), + error, + fromMaybe, + length, + maybe, + null, + ($), + (.), + ) import ClassyPrelude.Conduit - ( ($), - Integral(div), - Monad((>>=), return), - Num((-), (+), (*)), - Ord(max), - Semigroup((<>)), - Maybe(Just, Nothing), - ByteString, - MonadIO, - ConduitT, - (.), - fromMaybe, - maybe, - error, - length, - null, - IsSequence(drop, splitAt), - await, - yield ) + ( ByteString, + ConduitT, + Integral (div), + IsSequence (drop, splitAt), + Maybe (Just, Nothing), + Monad (return, (>>=)), + MonadIO, + Num ((*), (+), (-)), + Ord (max), + Semigroup ((<>)), + await, + error, + fromMaybe, + length, + maybe, + null, + yield, + ($), + (.), + ) import Crypto.Cipher.Types - ( BlockCipher(blockSize, cbcEncrypt, cbcDecrypt), IV, makeIV ) + ( BlockCipher (blockSize, cbcDecrypt, cbcEncrypt), + IV, + makeIV, + ) import Crypto.Data.Padding -encryptConduit :: (BlockCipher c, Monad m) => c -> IV c -> ByteString -> ConduitT ByteString ByteString m () -encryptConduit cipher iv partialBlock = await >>= \case - Nothing -> yield $ cbcEncrypt cipher iv $ pad (PKCS7 (blockSize cipher)) partialBlock - Just moreBytes -> let - fullBlocks = (length moreBytes + length partialBlock) `div` blockSize cipher +type EncFunc m = ConduitT ByteString ByteString m () + +type DecFunc m = ConduitT ByteString ByteString m () + +encryptConduit :: (BlockCipher c, MonadIO m) => c -> IV c -> ByteString -> EncFunc m +encryptConduit cipher iv partialBlock = + await >>= \case + Nothing -> yield $ cbcEncrypt cipher iv $ pad (PKCS7 (blockSize cipher)) partialBlock + Just moreBytes -> + let fullBlocks = (length moreBytes + length partialBlock) `div` blockSize cipher (thisTime, nextTime) = splitAt (fullBlocks * blockSize cipher) (partialBlock <> moreBytes) - in do - iv' <- if null thisTime then return iv else do - let cipherText = cbcEncrypt cipher iv thisTime - lastBlockOfCipherText = drop (length cipherText - blockSize cipher) cipherText - yield cipherText - maybe (error "makeIV failed") return $ makeIV lastBlockOfCipherText - encryptConduit cipher iv' nextTime + in do + iv' <- + if null thisTime + then return iv + else do + let cipherText = cbcEncrypt cipher iv thisTime + lastBlockOfCipherText = drop (length cipherText - blockSize cipher) cipherText + yield cipherText + maybe (error "makeIV failed") return $ makeIV lastBlockOfCipherText + encryptConduit cipher iv' nextTime -decryptConduit :: (BlockCipher c, MonadIO m) => c -> IV c -> ByteString -> ConduitT ByteString ByteString m () -decryptConduit cipher iv partialBlock = await >>= \case - Nothing -> if null partialBlock then return () else yield $ removePadding $ cbcDecrypt cipher iv partialBlock - Just moreBytes -> let - fullBlocks = (length moreBytes + length partialBlock) `div` blockSize cipher - (thisTime, nextTime) = splitAt ( max 0 (fullBlocks-1) * blockSize cipher) (partialBlock <> moreBytes) - in do - iv' <- if null thisTime then return iv else do - let plainText = cbcDecrypt cipher iv thisTime - lastBlockOfCipherText = drop (length thisTime - blockSize cipher) thisTime - yield plainText - maybe (error "makeIV failed") return $ makeIV lastBlockOfCipherText - decryptConduit cipher iv' nextTime - where removePadding = fromMaybe "hallo da " . unpad (PKCS7 (blockSize cipher)) +decryptConduit :: (BlockCipher c, MonadIO m) => c -> IV c -> ByteString -> DecFunc m +decryptConduit cipher iv partialBlock = + await >>= \case + Nothing -> if null partialBlock then return () else yield $ removePadding $ cbcDecrypt cipher iv partialBlock + Just moreBytes -> + let fullBlocks = (length moreBytes + length partialBlock) `div` blockSize cipher + (thisTime, nextTime) = splitAt (max 0 (fullBlocks -1) * blockSize cipher) (partialBlock <> moreBytes) + in do + iv' <- + if null thisTime + then return iv + else do + let plainText = cbcDecrypt cipher iv thisTime + lastBlockOfCipherText = drop (length thisTime - blockSize cipher) thisTime + yield plainText + maybe (error "makeIV failed") return $ makeIV lastBlockOfCipherText + decryptConduit cipher iv' nextTime + where + removePadding = fromMaybe "hallo da " . unpad (PKCS7 (blockSize cipher)) diff --git a/src/Foundation.hs b/src/Foundation.hs index 89f19dc..9844653 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -31,7 +31,7 @@ data App = App { appSettings :: AppSettings, appConnPool :: ConnectionPool, fileSystemServiceClient :: FileSystemServiceClient, - keyEncrptionKey :: KeyEncryptionKey, + keyEncrptionKey :: Maybe KeyEncryptionKey, appLogger :: Logger } diff --git a/src/Handler/Download.hs b/src/Handler/Download.hs index f4b3953..1459b82 100644 --- a/src/Handler/Download.hs +++ b/src/Handler/Download.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE GADTs #-} {-# HLINT ignore "Use join" #-} {-# HLINT ignore "Redundant bracket" #-} {-# LANGUAGE LambdaCase #-} @@ -32,6 +33,7 @@ import ClassyPrelude Utf8 (decodeUtf8), concat, concatMap, + const, defaultTimeLocale, fromMaybe, id, @@ -58,11 +60,13 @@ import ClassyPrelude ) import ClassyPrelude.Yesod ( ConduitM, + ConduitT, Entity (Entity), MonadHandler, MonadResource, PersistQueryRead (selectFirst), PersistUniqueRead (getBy), + ResourceT, ToJSON (toJSON), TypedContent, Value, @@ -73,12 +77,14 @@ import ClassyPrelude.Yesod invalidArgs, lookupGetParam, respondSource, + runConduit, runConduitRes, selectKeys, sendChunkBS, sendFile, sinkFile, status400, + takeWhileCE, yield, (.|), ) @@ -101,7 +107,7 @@ import FileSystemServiceClient.FileSystemServiceClient UploadedInode (parentPath), ) import Foundation (App (App, fileSystemServiceClient, keyEncrptionKey), Handler) -import KeyStorage (getEncKeyOrInternalError) +import KeyStorage (getDecryptionFunctionMaybeFromDB, getEncKeyOrInternalError) import Models.Inode ( Inode (lastUpdated, mimeType, name, path, size), fileSystemId, @@ -113,7 +119,7 @@ import Network.HTTP.Req (responseStatusMessage) import qualified Network.HTTP.Types as HttpTypes import System.Directory (doesDirectoryExist, removeFile) import System.IO.Temp (emptySystemTempFile) -import UnliftIO.Resource (allocate) +import UnliftIO.Resource (allocate, runResourceT) import Utils.HandlerUtils (handleApiCall, handleApiCall', lookupAuth, sendErrorOrRedirect, sendInternalError) import Utils.ZipFile import Yesod.Routes.TH.Types (flatten) @@ -141,18 +147,21 @@ getDownloadR path = do [] -> sendErrorOrRedirect status400 $ toJSON $ RestApiStatus "Can not download a empty folder." "Bad Request" [singleInode] -> do liftIO $ print $ size singleInode - (inode, (key, iv)) <- runDB $ getEncKeyOrInternalError singleInode kek + (inode, decFunc) <- getDecryptionFunctionMaybeFromDB singleInode kek + addHeader "Content-Disposition" $ pack ("attachment; filename=\"" ++ Models.Inode.name singleInode ++ "\"") addHeader "Content-Length" $ tshow $ size singleInode respondSource (S8.pack $ fromMaybe "application/octet-stream" (mimeType singleInode)) $ retrieveFile singleInode - .| decryptConduit key iv mempty + .| decFunc .| awaitForever sendChunkBS first : moreInodes -> do let archiveName = getFirstPathPiece first addHeader "Content-Disposition" ("attachment; filename=\"" ++ pack archiveName ++ ".zip" ++ "\"") - encKeysWithInodes <- mapM (\inode -> runDB $ getEncKeyOrInternalError inode kek) (first : moreInodes) - (_, tempFile) <- allocate (makeAllocateResource encKeysWithInodes) freeResource + encKeysWithInodes <- mapM (`getDecryptionFunctionMaybeFromDB` kek) (first : moreInodes) + path <- liftIO $ emptySystemTempFile "FileFighterFileHandler.zip" + runConduit $ createZip encKeysWithInodes path + (_, tempFile) <- allocate (makeAllocateResource path) freeResource sendFile "application/zip" tempFile justOrInternalError :: MonadHandler m => Maybe a -> m a @@ -166,11 +175,8 @@ lookupPaths parentPath = do Just inodeNames -> pure $ map (\name -> fromMultiPiece $ parentPath <> [name]) inodeNames Nothing -> pure [fromMultiPiece parentPath] -makeAllocateResource :: [(Inode, (AES256, IV AES256))] -> IO FilePath -makeAllocateResource inodesWithKeys = do - path <- emptySystemTempFile "FileFighterFileHandler.zip" - createZip inodesWithKeys path - return path +makeAllocateResource :: FilePath -> IO FilePath +makeAllocateResource = return freeResource :: FilePath -> IO () freeResource = removeFile diff --git a/src/Handler/Preview.hs b/src/Handler/Preview.hs index 1739a76..f061ffe 100644 --- a/src/Handler/Preview.hs +++ b/src/Handler/Preview.hs @@ -44,7 +44,7 @@ import FileStorage (filterFiles, retrieveFile) import FileSystemServiceClient.FileSystemServiceClient (FileSystemServiceClient (getInodeContent)) import FileSystemServiceClient.FileSystemServiceClient hiding (mimeType) import Foundation -import KeyStorage (getEncKeyOrInternalError) +import KeyStorage (getDecryptionFunctionMaybeFromDB, getEncKeyOrInternalError) import Models.Inode import Models.Path (fromMultiPiece) import Models.RestApiStatus (RestApiStatus (RestApiStatus)) @@ -62,9 +62,9 @@ getPreviewR path = do inodes <- handleApiCall responseBody' responseStatusCode responseStatusMessage case map (\i -> (i, filterFiles i)) inodes of [(inode, True)] -> do - (inode, (key, iv)) <- runDB $ getEncKeyOrInternalError inode kek + (inode, decryptFunc) <- getDecryptionFunctionMaybeFromDB inode kek respondSource (S8.pack $ fromMaybe "application/octet-stream" (mimeType inode)) $ retrieveFile inode - .| decryptConduit key iv mempty + .| decryptFunc .| awaitForever sendChunkBS _ -> sendErrorOrRedirect status400 $ toJSON $ RestApiStatus "Can not preview a folder." "Bad Request" diff --git a/src/Handler/Upload.hs b/src/Handler/Upload.hs index bce10a7..31afa09 100644 --- a/src/Handler/Upload.hs +++ b/src/Handler/Upload.hs @@ -5,12 +5,16 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-} {-# OPTIONS_GHC -Wno-deprecations #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Redundant bracket" #-} -- | module Handler.Upload where import ClassyPrelude ( Applicative ((<*>)), + Bool (True), ByteString, Eq ((/=)), IO, @@ -22,6 +26,7 @@ import ClassyPrelude Monoid (mempty), Show (show), Text, + id, print, singleton, undefined, @@ -43,6 +48,7 @@ import ClassyPrelude.Yesod runConduitRes, (.|), ) +import ConduitHelper (idC) import Crypto.Cipher.AES import Crypto.Cipher.Types (BlockCipher, IV, cipherInit, makeIV) import Crypto.CryptoConduit (encryptConduit) @@ -92,7 +98,7 @@ import Yesod.Core ) import Yesod.Core.Handler (sendResponseCreated) import Yesod.Core.Types (FileInfo (fileSourceRaw), loggerPutStr) -import Prelude (read) +import Prelude (Bool (True), const, read) postUploadR :: Handler Value postUploadR = do @@ -113,9 +119,14 @@ postUploadR = do case filter filterFiles createdInodes of [singleInode] -> do (alloc, encKey') <- liftIO $ makeAllocateResource kek singleInode - runDB $ storeEncKey singleInode encKey' - (_, _) <- allocate alloc (makeFreeResource file singleInode) - return responseBody + case kek of + Nothing -> do + (_, _) <- allocate alloc (makeFreeResource file singleInode) + return responseBody + Just kek -> do + runDB $ storeEncKey singleInode encKey' + (_, _) <- allocate alloc (makeFreeResource file singleInode) + return responseBody _ -> sendInternalError performPreflight :: (MonadHandler m, RedirectUrl (HandlerSite m) (Route App, [(Text, Text)])) => FileSystemServiceClient -> Text -> m () @@ -154,19 +165,20 @@ getRealFileSize fileInfo = do .| lengthCE -- this creates the encryptionKey by generating it -makeAllocateResource :: KeyEncryptionKey -> Inode -> IO (IO (AES256, IV AES256), EncKey) -makeAllocateResource kek inode = do +makeAllocateResource :: Maybe KeyEncryptionKey -> Inode -> IO (IO (ConduitT ByteString ByteString (ResourceT IO) ()), Maybe EncKey) +makeAllocateResource Nothing inode = return ((return idC), Nothing) +makeAllocateResource (Just kek) inode = do secretKey :: Crypto.Types.Key AES256 ByteString <- genSecretKey (undefined :: AES256) 32 let Key keyBytes = secretKey ivBytes <- genRandomIV (undefined :: AES256) let encKey' = EncKey (encryptWithKek kek keyBytes) ivBytes - return (return (initCipher secretKey, initIV ivBytes), encKey') + return (return $ encryptConduit (initCipher secretKey) (initIV ivBytes) mempty, Just encKey') -- this takes the encryption information and encrypts and moves the file after the response has been send -makeFreeResource :: FileInfo -> Inode -> (AES256, IV AES256) -> IO () -makeFreeResource fileInfo inode (cipher, iv) = do +makeFreeResource :: FileInfo -> Inode -> (ConduitT ByteString ByteString (ResourceT IO) ()) -> IO () +makeFreeResource fileInfo inode encryptFunc = do fileDest <- storeFile inode runConduitRes $ fileSource fileInfo - .| encryptConduit cipher iv mempty + .| encryptFunc .| fileDest diff --git a/src/KeyStorage.hs b/src/KeyStorage.hs index 574bda0..e04462f 100644 --- a/src/KeyStorage.hs +++ b/src/KeyStorage.hs @@ -10,10 +10,12 @@ -- | module KeyStorage where -import ClassyPrelude (Handler, Maybe (Just, Nothing), MonadIO (liftIO), ReaderT, maybe, throwIO) -import ClassyPrelude.Yesod (ErrorResponse (NotFound), MonadHandler, PersistStoreRead (get), YesodPersist (YesodPersistBackend, runDB), return, ($)) +import ClassyPrelude (Bool (True), ByteString, Handler, IO, Maybe (Just, Nothing), MonadIO (liftIO), Monoid (mempty), ReaderT, const, maybe, throwIO) +import ClassyPrelude.Yesod (ConduitT, ErrorResponse (NotFound), MonadHandler, PersistStoreRead (get), ResourceT, YesodPersist (YesodPersistBackend, runDB), return, takeWhileCE, ($)) +import ConduitHelper (idC) import Crypto.Cipher.AES (AES256) import Crypto.Cipher.Types (IV) +import Crypto.CryptoConduit (decryptConduit) import Crypto.Init (initCipher, initIV) import Crypto.KeyEncrptionKey (KeyEncryptionKey, decryptWithKek) import Crypto.Types (Key (Key)) @@ -25,30 +27,36 @@ import Models.Inode (Inode (Inode, fileSystemId)) import Utils.HandlerUtils (sendInternalError) import Yesod.Core.Types (HandlerContents (HCError)) +getDecryptionFunctionMaybeFromDB inode kek = do + case kek of + Just kek -> runDB $ getEncKeyOrInternalError inode kek + Nothing -> return (inode, idC) + getEncKeyOrInternalError :: (MonadHandler m, PersistRecordBackend EncKey MongoContext, PersistQueryRead MongoContext) => Inode -> KeyEncryptionKey -> - ReaderT MongoContext m (Inode, (AES256, IV AES256)) + ReaderT MongoContext m (Inode, (ConduitT ByteString ByteString m ())) getEncKeyOrInternalError inode kek = do mres :: (Maybe (EncKey)) <- get $ EncKeyKey (fileSystemId inode) case mres of Nothing -> sendInternalError Just (encKey) -> do - let key = initCipher $ Key (decryptWithKek kek $ encKeyCipherKey encKey) + let key :: AES256 = initCipher $ Key (decryptWithKek kek $ encKeyCipherKey encKey) let iv = (initIV $ encKeyCipherIv encKey) - return (inode, (key, iv)) + return (inode, decryptConduit key iv mempty) storeEncKey :: (MonadIO m, PersistRecordBackend EncKey MongoContext) => Inode -> - EncKey -> + Maybe EncKey -> ReaderT MongoContext m () -storeEncKey inode encKey = do +storeEncKey inode (Just encKey) = do let dbKey = EncKeyKey (fileSystemId inode) insertKey dbKey encKey get dbKey return () +storeEncKey inode (Nothing) = return () deleteEncKey :: (MonadHandler m, PersistRecordBackend EncKey MongoContext, PersistQueryRead MongoContext) => diff --git a/src/Settings.hs b/src/Settings.hs index 6d0c019..96b31e3 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -33,7 +33,7 @@ data AppSettings = AppSettings { appProfile :: String, appDatabaseConf :: MongoConf, fileSystemServiceSettings :: FileSystemServiceSettings, - encryptionPassword :: String + encryptionPassword :: Maybe String } deriving (Generic) diff --git a/src/Utils/ZipFile.hs b/src/Utils/ZipFile.hs index f3f3ad5..bc45fd8 100644 --- a/src/Utils/ZipFile.hs +++ b/src/Utils/ZipFile.hs @@ -1,4 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Redundant bracket" #-} -- | module Utils.ZipFile where @@ -8,21 +11,19 @@ import ClassyPrelude.Conduit import Codec.Archive.Zip.Conduit.Zip import Crypto.Cipher.AES import Crypto.Cipher.Types -import Crypto.CryptoConduit (decryptConduit) +import Crypto.CryptoConduit (DecFunc, decryptConduit) import Data.Time import FileStorage (getInodeModifcationTime, retrieveFile) import qualified Models.Inode -createZip :: [(Models.Inode.Inode, (AES256, IV AES256))] -> FilePath -> IO () +createZip :: (MonadIO m, MonadResource m, MonadThrow m, PrimMonad m) => [(Models.Inode.Inode, (DecFunc m))] -> FilePath -> (ConduitT () Void m ()) createZip inodes filename = do - timeZone <- liftIO getCurrentTimeZone - runConduitRes $ - generateZipEntries inodes timeZone - .| void (zipStream zipOptions) - .| sinkFile filename - -generateZipEntries :: (MonadIO m, MonadResource m) => [(Models.Inode.Inode, (AES256, IV AES256))] -> TimeZone -> ConduitM () (ZipEntry, ZipData m) m () -generateZipEntries ((currentInode, (key, iv)) : nextInodes) timeZone = do + timeZone <- + liftIO getCurrentTimeZone + generateZipEntries inodes timeZone .| void (zipStream zipOptions) .| sinkFile filename + +generateZipEntries :: (MonadIO m, MonadResource m) => [(Models.Inode.Inode, (DecFunc m))] -> TimeZone -> ConduitM () (ZipEntry, ZipData m) m () +generateZipEntries ((currentInode, decryptFunc) : nextInodes) timeZone = do let nameInZip = fromMaybe (Models.Inode.name currentInode) $ Models.Inode.path currentInode let size' = Models.Inode.size currentInode timeStamp <- liftIO $ getTimestampForInode currentInode @@ -34,7 +35,7 @@ generateZipEntries ((currentInode, (key, iv)) : nextInodes) timeZone = do zipEntryExternalAttributes = Nothing } - yield (entry, ZipDataSource $retrieveFile currentInode .| decryptConduit key iv mempty) + yield (entry, ZipDataSource $ retrieveFile currentInode .| decryptFunc) generateZipEntries nextInodes timeZone return () generateZipEntries [] _ = return () From ae113cec915836f51e84a9f196faa4d3c453d098 Mon Sep 17 00:00:00 2001 From: qvalentin Date: Mon, 26 Sep 2022 10:13:03 +0200 Subject: [PATCH 23/35] Fix creation of FileHandler user in MongoDB --- config/settings.yml | 2 +- docker-compose.yml | 30 +++++++++++++----------- docker-entrypoint-initdb.d/mongo-init.js | 9 +++++++ 3 files changed, 26 insertions(+), 15 deletions(-) create mode 100644 docker-entrypoint-initdb.d/mongo-init.js diff --git a/config/settings.yml b/config/settings.yml index ea7efa8..6f0e379 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -7,7 +7,7 @@ fileSystemServiceSettings: encryptionPassword: "_env:ENCRYPTION_PASSWORD:changeThis" # set this to null to not use encryptio appDatabaseConf: - user: root + user: filehandler password: example host: "localhost" database: filehandler diff --git a/docker-compose.yml b/docker-compose.yml index b5df29a..23896a3 100644 --- a/docker-compose.yml +++ b/docker-compose.yml @@ -1,4 +1,4 @@ -version: '3.1' +version: '3.7' services: @@ -12,20 +12,22 @@ services: MONGO_INITDB: root MONGO_INITDB_ROOT_USERNAME: root MONGO_INITDB_ROOT_PASSWORD: example + volumes: + - ./docker-entrypoint-initdb.d/mongo-init.js:/docker-entrypoint-initdb.d/mongo-init.js:ro - mongo-express: - image: mongo-express - ports: - - 8081:8081 - networks: - - db - links: - - "mongo:db" - environment: - ME_CONFIG_MONGODB_ADMINUSERNAME: root - ME_CONFIG_MONGODB_ADMINPASSWORD: example - ME_CONFIG_MONGODB_URL: mongodb://root:example@mongo:27017/ - + # mongo-express: + # image: mongo-express + # ports: + # - 8081:8081 + # networks: + # - db + # links: + # - "mongo:db" + # environment: + # ME_CONFIG_MONGODB_ADMINUSERNAME: root + # ME_CONFIG_MONGODB_ADMINPASSWORD: example + # ME_CONFIG_MONGODB_URL: mongodb://root:example@mongo:27017/ + # networks: db: diff --git a/docker-entrypoint-initdb.d/mongo-init.js b/docker-entrypoint-initdb.d/mongo-init.js new file mode 100644 index 0000000..630c201 --- /dev/null +++ b/docker-entrypoint-initdb.d/mongo-init.js @@ -0,0 +1,9 @@ +print("Started Adding the Users."); +db = db.getSiblingDB("filehandler"); +print("db:" , db); +db.createUser({ + user: "filehandler", + pwd: "example", + roles: [{ role: "readWrite", db: "filehandler" }], +}); +print("End Adding the User Roles."); From 74de424aa365e0e491fa32555b826213ed2f0951 Mon Sep 17 00:00:00 2001 From: qvalentin Date: Mon, 3 Oct 2022 11:59:59 +0200 Subject: [PATCH 24/35] Make encryption optional and improve logging --- config/settings.yml | 2 +- src/Application.hs | 7 +++---- src/Handler/Download.hs | 5 +++-- src/Handler/Preview.hs | 1 - src/Handler/Upload.hs | 21 +++++---------------- src/Utils/HandlerUtils.hs | 13 +++++++++---- 6 files changed, 21 insertions(+), 28 deletions(-) diff --git a/config/settings.yml b/config/settings.yml index 6f0e379..fdb661d 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -4,7 +4,7 @@ fileSystemServiceSettings: url: "_env:FILESYSTEMSERVICE_URL:localhost" port: "_env:FILESYSTEMSERVICE_PORT:8080" -encryptionPassword: "_env:ENCRYPTION_PASSWORD:changeThis" # set this to null to not use encryptio +encryptionPassword: "_env:ENCRYPTION_PASSWORD:null" # set this to null to not use encryptio appDatabaseConf: user: filehandler diff --git a/src/Application.hs b/src/Application.hs index b10ff6e..1e3c3bd 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -21,7 +21,6 @@ import ClassyPrelude const, isJust, map, - print, when, ($), (<$>), @@ -79,7 +78,7 @@ import System.Log.FastLogger toLogStr, ) import Yesod.Core (mkYesodDispatch, toWaiApp) -import Yesod.Core.Types (Logger (loggerSet)) +import Yesod.Core.Types (Logger (loggerSet), loggerPutStr) import Yesod.Default.Config2 (makeYesodLogger) mkYesodDispatch "App" resourcesApp @@ -93,11 +92,11 @@ makeFoundation appSettings = do Nothing -> Nothing Just password -> Just password - print maybeEncryptionPassword - iv <- if isJust $ maybeEncryptionPassword then getOrCreateKekIV else return "FallBackIV" + iv <- if isJust maybeEncryptionPassword then getOrCreateKekIV else return "FallBackIV" let keyEncrptionKey = createKeyEncrptionKey <$> maybeEncryptionPassword <*> Just iv appConnPool <- createPoolConfig $ appDatabaseConf appSettings appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger + loggerPutStr appLogger $ if isJust maybeEncryptionPassword then "Using Encryption \n" else "Not using encryption \n" return App diff --git a/src/Handler/Download.hs b/src/Handler/Download.hs index 1459b82..35cfa94 100644 --- a/src/Handler/Download.hs +++ b/src/Handler/Download.hs @@ -3,6 +3,7 @@ {-# HLINT ignore "Redundant bracket" #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} @@ -42,7 +43,6 @@ import ClassyPrelude maybe, pack, parseTimeM, - print, pure, putStrLn, readFile, @@ -122,6 +122,7 @@ import System.IO.Temp (emptySystemTempFile) import UnliftIO.Resource (allocate, runResourceT) import Utils.HandlerUtils (handleApiCall, handleApiCall', lookupAuth, sendErrorOrRedirect, sendInternalError) import Utils.ZipFile +import Yesod.Core (logInfo) import Yesod.Routes.TH.Types (flatten) getDownloadR :: [Text] -> Handler TypedContent @@ -146,7 +147,7 @@ getDownloadR path = do case inodes of [] -> sendErrorOrRedirect status400 $ toJSON $ RestApiStatus "Can not download a empty folder." "Bad Request" [singleInode] -> do - liftIO $ print $ size singleInode + $(logInfo) $ pack $ "Dowload of Inode " <> show singleInode (inode, decFunc) <- getDecryptionFunctionMaybeFromDB singleInode kek addHeader "Content-Disposition" $ pack ("attachment; filename=\"" ++ Models.Inode.name singleInode ++ "\"") diff --git a/src/Handler/Preview.hs b/src/Handler/Preview.hs index f061ffe..a32ac92 100644 --- a/src/Handler/Preview.hs +++ b/src/Handler/Preview.hs @@ -14,7 +14,6 @@ import ClassyPrelude fromMaybe, intercalate, map, - print, ($), (.), (<>), diff --git a/src/Handler/Upload.hs b/src/Handler/Upload.hs index 31afa09..37e4352 100644 --- a/src/Handler/Upload.hs +++ b/src/Handler/Upload.hs @@ -3,6 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -Wno-deferred-out-of-scope-variables #-} {-# OPTIONS_GHC -Wno-deprecations #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} @@ -27,27 +28,14 @@ import ClassyPrelude Show (show), Text, id, - print, + pack, singleton, undefined, ($), (.), (<$>), ) -import ClassyPrelude.Yesod - ( ConduitT, - FileInfo (fileContentType), - MonadHandler (HandlerSite), - PersistStoreWrite (insertKey), - RedirectUrl, - RenderRoute (Route), - Response (responseBody), - defaultMakeLogger, - lengthC, - lengthCE, - runConduitRes, - (.|), - ) +import ClassyPrelude.Yesod (ConduitT, FileInfo (fileContentType), MonadHandler (HandlerSite), PersistStoreWrite (insertKey), RedirectUrl, RenderRoute (Route), Response (responseBody), defaultMakeLogger, lengthC, lengthCE, logDebug, logInfo, runConduitRes, (.|)) import ConduitHelper (idC) import Crypto.Cipher.AES import Crypto.Cipher.Types (BlockCipher, IV, cipherInit, makeIV) @@ -90,6 +78,7 @@ import Yesod.Core fileSource, getYesod, invalidArgs, + logDebug, lookupBearerAuth, lookupHeader, notAuthenticated, @@ -114,8 +103,8 @@ postUploadR = do Nothing -> invalidArgs ["Missing required Header."] Just inode -> do (responseBody, responseStatusCode, responseStatusMessage) <- liftIO $ createInode authToken inode - liftIO $ print $ show responseBody createdInodes <- handleApiCall responseBody responseStatusCode responseStatusMessage + $(logInfo) $ pack $ show createdInodes case filter filterFiles createdInodes of [singleInode] -> do (alloc, encKey') <- liftIO $ makeAllocateResource kek singleInode diff --git a/src/Utils/HandlerUtils.hs b/src/Utils/HandlerUtils.hs index 1a5b425..bb308b1 100644 --- a/src/Utils/HandlerUtils.hs +++ b/src/Utils/HandlerUtils.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE NoImplicitPrelude #-} -- | @@ -13,21 +14,24 @@ import ClassyPrelude Monad (return, (>>=)), MonadIO (liftIO), Ord ((<), (<=)), + Show (show), Text, Utf8 (decodeUtf8), elem, maybe, otherwise, pack, - print, putStr, putStrLn, + unpack, ($), (&&), (.), (<$>), + (<>), ) import Data.Aeson +import qualified Data.Text as Text import Foundation import Models.RestApiStatus import Network.HTTP.Types @@ -38,6 +42,7 @@ import Yesod RedirectUrl, YesodRequest (reqAccept, reqWaiRequest), getRequest, + logError, lookupCookie, lookupGetParam, notAuthenticated, @@ -58,13 +63,13 @@ handleApiCall body statusCode statusMessage Success value -> return value Error e -> do - liftIO $ print e + $(logError) $ pack e sendInternalError | 400 <= statusCode && statusCode < 500 = do - liftIO $ print "4XX domain error" + $(logError) $ pack ("4XX domain error. StatusCode: " <> show statusCode <> " StatusMessage: ") <> decodeUtf8 statusMessage sendErrorOrRedirect (Status statusCode statusMessage) body --sendResponseStatus (Status statusCode statusMessage) body | otherwise = do - liftIO $ print body + $(logError) $ pack $ show body sendInternalError sendErrorOrRedirect :: (MonadHandler m, RedirectUrl (HandlerSite m) (Route App, [(Text, Text)])) => Status -> Value -> m a From c891525bcd0c72e0cd3f99405d1ecc697f2347ec Mon Sep 17 00:00:00 2001 From: qvalentin Date: Sat, 8 Oct 2022 17:39:40 +0200 Subject: [PATCH 25/35] Building docker container --- .dockerignore | 2 ++ Dockerfile | 13 +++++++------ build-docker.sh | 7 +++++++ stack.yaml | 1 + 4 files changed, 17 insertions(+), 6 deletions(-) create mode 100644 .dockerignore create mode 100755 build-docker.sh diff --git a/.dockerignore b/.dockerignore new file mode 100644 index 0000000..86e23e6 --- /dev/null +++ b/.dockerignore @@ -0,0 +1,2 @@ +.git +" diff --git a/Dockerfile b/Dockerfile index 8936738..0eb4cda 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,13 +1,14 @@ -FROM ubuntu:latest +FROM debian:testing-slim ARG BINLOCATION -ENV RESTURL=FileFighterREST -ENV PROFILE=prod +ENV FILESYSTEMSERVICE_URL=fss +ENV FILESYSTEMSERVICE_PORT=8080 +ENV APP_PROFILE=prod +ENV ENCRYPTION_PASSWORD=null -RUN apt-get update && apt-get upgrade -y # Copy over the source code and make it executable. -ADD $BINLOCATION/bin/Filehandler-exe /usr/local/bin/filehandler-exe +ADD $BINLOCATION/bin/FileHandlerYesod /usr/local/bin/filehandler-exe RUN chmod +x /usr/local/bin/filehandler-exe # TODO: because we want to write to a host directory we must run as root, or change the permissions of the directory @@ -20,4 +21,4 @@ RUN chmod +x /usr/local/bin/filehandler-exe # using exec solves ctl + c issues CMD exec /usr/local/bin/filehandler-exe ${RESTURL} $PROFILE WORKDIR /workdir -EXPOSE 5000 \ No newline at end of file +EXPOSE 5000 diff --git a/build-docker.sh b/build-docker.sh new file mode 100755 index 0000000..d5ed4d9 --- /dev/null +++ b/build-docker.sh @@ -0,0 +1,7 @@ +#!/usr/bin/env sh + + + +BINLOCATION=$(stack path --local-install-root) +BINLOCATION=$(realpath --relative-to=. "$BINLOCATION") +docker build -t filefighter/filehandler:feature . --build-arg BINLOCATION="$BINLOCATION" diff --git a/stack.yaml b/stack.yaml index 43affd6..ef9dffd 100644 --- a/stack.yaml +++ b/stack.yaml @@ -66,3 +66,4 @@ extra-deps: # # Allow a newer minor version of GHC than the snapshot specifies # compiler-check: newer-minor + From f09f9823aba38f02532ce90fa24679e09006d895 Mon Sep 17 00:00:00 2001 From: qvalentin Date: Sat, 8 Oct 2022 17:47:14 +0200 Subject: [PATCH 26/35] Add db setting to env --- Dockerfile | 7 +++++-- config/settings.yml | 8 ++++---- 2 files changed, 9 insertions(+), 6 deletions(-) diff --git a/Dockerfile b/Dockerfile index 0eb4cda..6bc8880 100644 --- a/Dockerfile +++ b/Dockerfile @@ -5,7 +5,10 @@ ENV FILESYSTEMSERVICE_URL=fss ENV FILESYSTEMSERVICE_PORT=8080 ENV APP_PROFILE=prod ENV ENCRYPTION_PASSWORD=null - +ENV DB_USERNAME=filehandler +ENV DB_PASSWORD=changeThis +ENV DB_CONTAINER_NAME=db +ENV DB_NAME=filehandler # Copy over the source code and make it executable. ADD $BINLOCATION/bin/FileHandlerYesod /usr/local/bin/filehandler-exe @@ -19,6 +22,6 @@ RUN chmod +x /usr/local/bin/filehandler-exe # We're all ready, now just configure our image to run the server on # launch from the correct working directory. # using exec solves ctl + c issues -CMD exec /usr/local/bin/filehandler-exe ${RESTURL} $PROFILE +CMD exec /usr/local/bin/filehandler-exe WORKDIR /workdir EXPOSE 5000 diff --git a/config/settings.yml b/config/settings.yml index fdb661d..d8d344c 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -7,8 +7,8 @@ fileSystemServiceSettings: encryptionPassword: "_env:ENCRYPTION_PASSWORD:null" # set this to null to not use encryptio appDatabaseConf: - user: filehandler - password: example - host: "localhost" - database: filehandler + user: "_env:DB_USERNAME:filehandler" + password: "_env:DB_PASSWORD:changeThis" + host: "_env:DB_CONTAINER_NAME:localhost" + database: "_env:DB_NAME:filehandler" connections: 9 From 6b57935c18433e3e74f08ac1dde427202c81e34a Mon Sep 17 00:00:00 2001 From: qvalentin Date: Sun, 9 Oct 2022 13:11:29 +0200 Subject: [PATCH 27/35] Add Banner and cors config --- Dockerfile | 1 + config/settings.yml | 2 ++ src/Application.hs | 20 ++++++++---- src/FileStorage.hs | 6 ++-- src/Settings.hs | 60 +++++++++++++++++++++++++++++----- src/Utils/FileFighterBanner.hs | 24 ++++++++++++++ 6 files changed, 95 insertions(+), 18 deletions(-) create mode 100644 src/Utils/FileFighterBanner.hs diff --git a/Dockerfile b/Dockerfile index 6bc8880..92b1850 100644 --- a/Dockerfile +++ b/Dockerfile @@ -9,6 +9,7 @@ ENV DB_USERNAME=filehandler ENV DB_PASSWORD=changeThis ENV DB_CONTAINER_NAME=db ENV DB_NAME=filehandler +ENV FRONTEND_ORIGIN=http://localhost:80 # Copy over the source code and make it executable. ADD $BINLOCATION/bin/FileHandlerYesod /usr/local/bin/filehandler-exe diff --git a/config/settings.yml b/config/settings.yml index d8d344c..57e38bd 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -4,6 +4,8 @@ fileSystemServiceSettings: url: "_env:FILESYSTEMSERVICE_URL:localhost" port: "_env:FILESYSTEMSERVICE_PORT:8080" +frontendOrigin: "_env:FRONTEND_ORIGIN:http://localhost:3000" + encryptionPassword: "_env:ENCRYPTION_PASSWORD:null" # set this to null to not use encryptio appDatabaseConf: diff --git a/src/Application.hs b/src/Application.hs index 1e3c3bd..300bf49 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -12,12 +12,17 @@ where import ClassyPrelude ( Applicative ((<*>)), Bool (False, True), + ByteString, Eq ((/=), (==)), Functor (fmap), IO, Maybe (Just, Nothing), Monad (return, (>>=)), Num ((*)), + Semigroup ((<>)), + Show (show), + String, + Text, const, isJust, map, @@ -28,6 +33,7 @@ import ClassyPrelude ) import ClassyPrelude.Yesod (Default (def), PersistConfig (createPoolConfig)) import Crypto.KeyEncrptionKey (createKeyEncrptionKey, getOrCreateKekIV) +import Data.ByteString.Char8 (pack) import Data.Yaml.Config (loadYamlSettingsArgs, useEnv) import FileSystemServiceClient.FileSystemServiceClient (makeFileSystemServiceClient) import Foundation @@ -69,7 +75,7 @@ import Network.Wai.Middleware.Cors import Network.Wai.Middleware.RequestLogger (Destination (Logger), IPAddrSource (FromFallback, FromSocket), OutputFormat (Apache, Detailed), RequestLoggerSettings (destination, outputFormat), mkRequestLogger) import Network.Wai.Parse () import Settings - ( AppSettings (appDatabaseConf, appProfile, encryptionPassword, fileSystemServiceSettings), + ( AppSettings (appDatabaseConf, appProfile, encryptionPassword, fileSystemServiceSettings, frontendOrigin), configSettingsYmlValue, ) import System.Log.FastLogger @@ -77,6 +83,7 @@ import System.Log.FastLogger newStdoutLoggerSet, toLogStr, ) +import Utils.FileFighterBanner (printBanner) import Yesod.Core (mkYesodDispatch, toWaiApp) import Yesod.Core.Types (Logger (loggerSet), loggerPutStr) import Yesod.Default.Config2 (makeYesodLogger) @@ -85,8 +92,8 @@ mkYesodDispatch "App" resourcesApp makeFoundation :: AppSettings -> IO App makeFoundation appSettings = do + printBanner let fssC = makeFileSystemServiceClient (fileSystemServiceSettings appSettings) - let maybeEncryptionPassword = case encryptionPassword appSettings of Just "null" -> Nothing Nothing -> Nothing @@ -96,7 +103,7 @@ makeFoundation appSettings = do let keyEncrptionKey = createKeyEncrptionKey <$> maybeEncryptionPassword <*> Just iv appConnPool <- createPoolConfig $ appDatabaseConf appSettings appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger - loggerPutStr appLogger $ if isJust maybeEncryptionPassword then "Using Encryption \n" else "Not using encryption \n" + loggerPutStr appLogger $ toLogStr $ "Using Config: \n" <> show appSettings <> "\n" return App @@ -139,12 +146,13 @@ appMain = do application <- toWaiApp app - run 5000 $ cors (const devCorsPolicy) application + run 5000 $ cors (const $ corsPolicy $ pack $ frontendOrigin settings) application -devCorsPolicy = +corsPolicy :: ByteString -> Maybe CorsResourcePolicy +corsPolicy frontendOrigin = Just CorsResourcePolicy - { corsOrigins = Just (["http://localhost:3000"], True), + { corsOrigins = Just ([frontendOrigin], True), corsMethods = ["GET", "POST", "DELETE"], corsRequestHeaders = ["Authorization", "content-type", "X-FF-IDS", "X-FF-ID", "X-FF-NAME", "X-FF-PATH", "X-FF-SIZE", "X-FF-PARENT-PATH", "X-FF-RELATIVE-PATH", "X-FF-PARENT-PATH"], corsExposedHeaders = Just ["Content-Disposition"], diff --git a/src/FileStorage.hs b/src/FileStorage.hs index 40f6859..012880f 100644 --- a/src/FileStorage.hs +++ b/src/FileStorage.hs @@ -11,13 +11,13 @@ import Yesod storeFile :: MonadResource m => Inode -> IO (ConduitT ByteString o m ()) storeFile inode = do - let id = show $ fileSystemId inode + let id = fileSystemId inode createDirectoryIfMissing True $ take 1 id return $sinkFileCautious (getPathFromFileId id) retrieveFile :: MonadResource m => Inode -> ConduitT i ByteString m () retrieveFile inode = do - let id = show $ fileSystemId inode + let id = fileSystemId inode sourceFile (getPathFromFileId id) getPathFromFileId :: String -> String @@ -25,7 +25,7 @@ getPathFromFileId id = take 1 id ++ ("/" ++ id) getInodeModifcationTime :: Inode -> IO UTCTime getInodeModifcationTime inode = - let id = show $ fileSystemId inode + let id = fileSystemId inode in getModificationTime (getPathFromFileId id) filterFiles :: Inode -> Bool diff --git a/src/Settings.hs b/src/Settings.hs index 96b31e3..fa5d881 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -1,14 +1,32 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Redundant bracket" #-} -- | module Settings where import ClassyPrelude.Yesod + ( ByteString, + FromJSON, + Generic, + Int, + Maybe (..), + Semigroup ((<>)), + Show (show), + String, + Value, + either, + id, + ($), + (<$>), + ) import qualified Control.Exception as Exception import Data.Aeson ( Result (..), @@ -19,31 +37,55 @@ import Data.Aeson ) import Data.FileEmbed (embedFile) import Data.Yaml (decodeEither') -import Database.Persist.MongoDB (MongoConf) -import GHC.Generics +import Database.MongoDB (Password) +import Database.Persist.MongoDB (MongoAuth (MongoAuth), MongoConf (mgAuth)) +import GHC.Generics () +import Models.User (User (username)) import Network.Wai.Handler.Warp (HostPreference) import Yesod.Default.Config2 (applyEnvValue, configSettingsYml) -import Yesod.Default.Util - ( WidgetFileSettings, - widgetFileNoReload, - widgetFileReload, - ) + +type EncryptionPassword = Maybe String + +instance {-# OVERLAPS #-} Show EncryptionPassword where + show Nothing = "Not using encryption" + show (Just password) = "Using encryption with the specified password" data AppSettings = AppSettings { appProfile :: String, appDatabaseConf :: MongoConf, fileSystemServiceSettings :: FileSystemServiceSettings, - encryptionPassword :: Maybe String + encryptionPassword :: EncryptionPassword, + frontendOrigin :: String } deriving (Generic) instance FromJSON AppSettings +instance Show AppSettings where + show (AppSettings appProfile appDatabaseConf fileSystemServiceSettings encryptionPassword frontendOrigin) = + "Profile: " <> appProfile <> "\n" + <> "DB conf: " + <> show (hidePasswordInMongoConf appDatabaseConf) + <> "\n" + <> "FSS Config: " + <> show fileSystemServiceSettings + <> "\n" + <> "frontend origin: " + <> frontendOrigin + <> "\n" + <> "Encryption Settings: " + <> show encryptionPassword + +hidePasswordInMongoConf :: MongoConf -> MongoConf +hidePasswordInMongoConf conf = conf {mgAuth = (overwritePassword <$> mgAuth conf)} + where + overwritePassword (MongoAuth user _) = MongoAuth user "****" + data FileSystemServiceSettings = FileSystemServiceSettings { url :: String, port :: Int } - deriving (Generic) + deriving (Generic, Show) instance FromJSON FileSystemServiceSettings diff --git a/src/Utils/FileFighterBanner.hs b/src/Utils/FileFighterBanner.hs new file mode 100644 index 0000000..90b621f --- /dev/null +++ b/src/Utils/FileFighterBanner.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +module Utils.FileFighterBanner where + +import ClassyPrelude + +printBanner :: IO () +printBanner = do + echo " _____ _ _ _____ _ _ _ " + echo " | ___| (_) | | ___ | ___| (_) __ _ | |__ | |_ ___ _ __ " + echo " | |_ | | | | / _ \\ | |_ | | / _\\`| | '_ \\ | __| / _ \\ | '__|" + echo " | _| | | | | | __/ | _| | | | (_| | | | | | | |_ | __/ | | " + echo " |_| |_| |_| \\___| |_| |_| \\__, | |_| |_| \\__| \\___| |_| " + echo " |___/ " + echo " Version $1 Last updated: $2" + echo " Developed by Gimleux, Valentin, Open-Schnick. " + echo " Development Blog: https://blog.filefighter.de " + echo " The code can be found at: https://www.github.com/filefighter " + echo "" + echo "-------------------------< $3 >---------------------------" + echo "" + where + echo = putStrLn From d48009aed2a6510e367fbb5bd94d359b36bb57d0 Mon Sep 17 00:00:00 2001 From: qvalentin Date: Sun, 9 Oct 2022 13:59:05 +0200 Subject: [PATCH 28/35] use /api/api --- .../FileSystemServiceClient.hs | 25 ++++++++++--------- 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/src/FileSystemServiceClient/FileSystemServiceClient.hs b/src/FileSystemServiceClient/FileSystemServiceClient.hs index a86532a..dbaf24f 100644 --- a/src/FileSystemServiceClient/FileSystemServiceClient.hs +++ b/src/FileSystemServiceClient/FileSystemServiceClient.hs @@ -44,7 +44,7 @@ data FileSystemServiceClient = FileSystemServiceClient { deleteInode :: Text -> [Text] -> IO (Value, Int, ByteString), createInode :: Text -> UploadedInode -> IO (Value, Int, ByteString), preflightInode :: Text -> PreflightInode -> IO (Value, Int, ByteString), - getInodeInfo :: Text -> String -> IO (Value, Int, ByteString), + getInodeInfo :: Text -> Path -> IO (Value, Int, ByteString), getInodeContent :: Text -> Path -> IO (Value, Int, ByteString) } @@ -84,7 +84,7 @@ makeDeleteInode r@FileSystemServiceSettings {url = url, port = port} authorizati r <- req DELETE - (http (pack url) /: "api" /: "filesystem" /: "delete") + (http (pack url) /: "api" /: "api" /: "filesystem" /: "delete") NoReqBody jsonResponse ( oAuth2Bearer' (encodeUtf8 authorization) <> Req.port port @@ -99,8 +99,7 @@ makeCreateInode r@FileSystemServiceSettings {url = url, port = port} authorizati r <- req POST -- method - --(http (DataText.pack restUrl) /: "t/os3vu-1615111052/post") - (http (pack url) /: "api" /: "filesystem" /: "upload") + (http (pack url) /: "api" /: "api" /: "filesystem" /: "upload") (ReqBodyJson uploadedInode) -- use built-in options or add your own jsonResponse (oAuth2Bearer' (encodeUtf8 authorization) <> Req.port port) -- parentID not in Headers @@ -111,22 +110,24 @@ makePreflightInode r@FileSystemServiceSettings {url = url, port = port} authoriz r <- req POST -- method - (http (pack url) /: "api" /: "filesystem" /: "preflight") + (http (pack url) /: "api" /: "api" /: "filesystem" /: "preflight") (ReqBodyJson preflightInode) jsonResponse (oAuth2Bearer' (encodeUtf8 authorization) <> Req.port port) -- parentID not in Headers return (responseBody r, responseStatusCode r, responseStatusMessage r) -makeGetInodeInfo :: FileSystemServiceSettings -> Text -> String -> IO (Value, Int, ByteString) -makeGetInodeInfo r@FileSystemServiceSettings {url = url, port = port} authorization id = runReq (defaultHttpConfig {httpConfigCheckResponse = httpConfigDontCheckResponse}) $ do +makeGetInodeInfo :: FileSystemServiceSettings -> Text -> Path -> IO (Value, Int, ByteString) +makeGetInodeInfo r@FileSystemServiceSettings {url = url, port = port} authorization path = runReq (defaultHttpConfig {httpConfigCheckResponse = httpConfigDontCheckResponse}) $ do r <- req GET -- method - (http (pack url) /: "v1" /: "filesystem" /: pack id /: "info") -- safe by construction URL - --(http (DataText.pack restUrl) /: "v1" /: "filesystem" /: id /: "info" ) -- safe by construction URL + (http (pack url) /: "api" /: "api" /: "filesystem" /: "info") NoReqBody -- use built-in options or add your own - jsonResponse -- specify how to interpret response - (oAuth2Bearer' (encodeUtf8 authorization) <> Req.port port) + jsonResponse + ( oAuth2Bearer' (encodeUtf8 authorization) + <> Req.port port + <> header "X-FF-PATH" (toByteString path) + ) -- mempty -- query params, headers, explicit port number, etc. return (responseBody r, responseStatusCode r, responseStatusMessage r) @@ -135,7 +136,7 @@ makeGetInodeContent r@FileSystemServiceSettings {url = url, port = port} authori r <- req GET -- method - (http (pack url) /: "api" /: "filesystem" /: "download") -- safe by construction URL + (http (pack url) /: "api" /: "api" /: "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 jsonResponse -- specify how to interpret response From 0d14eaa75c0d9da8de8db8959177bce28b137348 Mon Sep 17 00:00:00 2001 From: qvalentin Date: Sun, 9 Oct 2022 14:04:37 +0200 Subject: [PATCH 29/35] Fix missing dependency --- Dockerfile | 2 ++ 1 file changed, 2 insertions(+) diff --git a/Dockerfile b/Dockerfile index 92b1850..b97af0f 100644 --- a/Dockerfile +++ b/Dockerfile @@ -11,6 +11,8 @@ ENV DB_CONTAINER_NAME=db ENV DB_NAME=filehandler ENV FRONTEND_ORIGIN=http://localhost:80 +RUN apt update && apt install netbase + # Copy over the source code and make it executable. ADD $BINLOCATION/bin/FileHandlerYesod /usr/local/bin/filehandler-exe RUN chmod +x /usr/local/bin/filehandler-exe From 0c84cc1d833d69cad06d6c86d216a0c1883843e3 Mon Sep 17 00:00:00 2001 From: qvalentin Date: Sun, 9 Oct 2022 18:41:59 +0200 Subject: [PATCH 30/35] Fix banner, more health info --- src/Application.hs | 8 ++++---- src/Handler/Health.hs | 16 ++++++++++++---- src/KeyStorage.hs | 17 ++++++++++++++--- src/Utils/FileFighterBanner.hs | 16 +++++++++++----- 4 files changed, 41 insertions(+), 16 deletions(-) diff --git a/src/Application.hs b/src/Application.hs index 300bf49..de4b158 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -92,7 +92,6 @@ mkYesodDispatch "App" resourcesApp makeFoundation :: AppSettings -> IO App makeFoundation appSettings = do - printBanner let fssC = makeFileSystemServiceClient (fileSystemServiceSettings appSettings) let maybeEncryptionPassword = case encryptionPassword appSettings of Just "null" -> Nothing @@ -103,6 +102,7 @@ makeFoundation appSettings = do let keyEncrptionKey = createKeyEncrptionKey <$> maybeEncryptionPassword <*> Just iv appConnPool <- createPoolConfig $ appDatabaseConf appSettings appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger + printBanner $ loggerPutStr appLogger loggerPutStr appLogger $ toLogStr $ "Using Config: \n" <> show appSettings <> "\n" return @@ -146,13 +146,13 @@ appMain = do application <- toWaiApp app - run 5000 $ cors (const $ corsPolicy $ pack $ frontendOrigin settings) application + run 5000 $ cors (const $ corsPolicy $ frontendOrigin settings) application -corsPolicy :: ByteString -> Maybe CorsResourcePolicy +corsPolicy :: String -> Maybe CorsResourcePolicy corsPolicy frontendOrigin = Just CorsResourcePolicy - { corsOrigins = Just ([frontendOrigin], True), + { corsOrigins = Just ([pack frontendOrigin], True), corsMethods = ["GET", "POST", "DELETE"], corsRequestHeaders = ["Authorization", "content-type", "X-FF-IDS", "X-FF-ID", "X-FF-NAME", "X-FF-PATH", "X-FF-SIZE", "X-FF-PARENT-PATH", "X-FF-RELATIVE-PATH", "X-FF-PARENT-PATH"], corsExposedHeaders = Just ["Content-Disposition"], diff --git a/src/Handler/Health.hs b/src/Handler/Health.hs index 3ad65f6..a83456f 100644 --- a/src/Handler/Health.hs +++ b/src/Handler/Health.hs @@ -11,6 +11,7 @@ import ClassyPrelude Int, Integer, IsSequence (filterM), + Maybe, MonadIO (liftIO), Show, String, @@ -24,8 +25,12 @@ import ClassyPrelude (), (=<<), ) +import Data.Version (showVersion) import Foundation +import KeyStorage (maybeCountKeys) import qualified Network.HTTP.Types as HttpTypes +import Paths_FileHandlerYesod () +import qualified Paths_FileHandlerYesod as BuildInfo import Settings (AppSettings (AppSettings), appProfile) import System.Directory ( doesDirectoryExist, @@ -38,7 +43,8 @@ data HealthInfo = HealthInfo { version :: String, deploymentType :: String, actualFilesSize :: Integer, - fileCount :: Int + fileCount :: Int, + keyCount :: Int } deriving (Show, Generic) @@ -46,15 +52,17 @@ instance ToJSON HealthInfo getHealthR :: Handler Value getHealthR = do - App {appSettings = AppSettings {appProfile = deploymentType}} <- getYesod + App {appSettings = AppSettings {appProfile = deploymentType}, keyEncrptionKey = kek} <- getYesod files <- liftIO $ concat <$> (mapM listDirectoryRelative =<< (filterM doesDirectoryExist =<< listDirectory ".")) actualFilesSize <- liftIO $ sum <$> mapM getFileSize files + keyCount <- maybeCountKeys kek let response = HealthInfo - { version = "0.2.1" :: String, + { version = showVersion BuildInfo.version, deploymentType = deploymentType, actualFilesSize = actualFilesSize, - fileCount = length files + fileCount = length files, + keyCount = keyCount } returnJson response diff --git a/src/KeyStorage.hs b/src/KeyStorage.hs index e04462f..433af95 100644 --- a/src/KeyStorage.hs +++ b/src/KeyStorage.hs @@ -10,8 +10,8 @@ -- | module KeyStorage where -import ClassyPrelude (Bool (True), ByteString, Handler, IO, Maybe (Just, Nothing), MonadIO (liftIO), Monoid (mempty), ReaderT, const, maybe, throwIO) -import ClassyPrelude.Yesod (ConduitT, ErrorResponse (NotFound), MonadHandler, PersistStoreRead (get), ResourceT, YesodPersist (YesodPersistBackend, runDB), return, takeWhileCE, ($)) +import ClassyPrelude (Bool (True), ByteString, Handler, IO, Int, Maybe (Just, Nothing), MonadIO (liftIO), Monoid (mempty), ReaderT, Traversable (mapM), any, const, length, maybe, throwIO) +import ClassyPrelude.Yesod (ConduitT, ErrorResponse (NotFound), Filter, MonadHandler, PersistQueryRead (count), PersistStoreRead (get), ResourceT, YesodPersist (YesodPersistBackend, runDB), return, selectList, takeWhileCE, ($)) import ConduitHelper (idC) import Crypto.Cipher.AES (AES256) import Crypto.Cipher.Types (IV) @@ -25,13 +25,24 @@ import Database.Persist.MongoDB (Entity (Entity), MongoContext, PersistQueryRead import Foundation (App) import Models.Inode (Inode (Inode, fileSystemId)) import Utils.HandlerUtils (sendInternalError) -import Yesod.Core.Types (HandlerContents (HCError)) +import Yesod.Core.Types (HandlerContents (HCError), HandlerFor) +getDecryptionFunctionMaybeFromDB :: (YesodPersist site, YesodPersistBackend site ~ MongoContext) => Inode -> Maybe KeyEncryptionKey -> Yesod.Core.Types.HandlerFor site (Inode, ConduitT ByteString ByteString (Yesod.Core.Types.HandlerFor site) ()) getDecryptionFunctionMaybeFromDB inode kek = do case kek of Just kek -> runDB $ getEncKeyOrInternalError inode kek Nothing -> return (inode, idC) +maybeCountKeys :: (YesodPersist site, YesodPersistBackend site ~ MongoContext, PersistRecordBackend EncKey MongoContext) => Maybe KeyEncryptionKey -> Yesod.Core.Types.HandlerFor site Int +maybeCountKeys Nothing = return 0 +maybeCountKeys (Just kek) = do + runDB countEncKeys + +countEncKeys :: (MonadIO m, PersistRecordBackend EncKey MongoContext, PersistQueryRead MongoContext) => ReaderT MongoContext m Int +countEncKeys = do + let filter = [] :: [Filter EncKey] + count filter + getEncKeyOrInternalError :: (MonadHandler m, PersistRecordBackend EncKey MongoContext, PersistQueryRead MongoContext) => Inode -> diff --git a/src/Utils/FileFighterBanner.hs b/src/Utils/FileFighterBanner.hs index 90b621f..b247aea 100644 --- a/src/Utils/FileFighterBanner.hs +++ b/src/Utils/FileFighterBanner.hs @@ -4,21 +4,27 @@ module Utils.FileFighterBanner where import ClassyPrelude +import ClassyPrelude.Yesod (logInfo) +import Data.Version (showVersion) +import Paths_FileHandlerYesod (version) +import System.Log.FastLogger (LogStr, ToLogStr (toLogStr)) -printBanner :: IO () -printBanner = do +printBanner :: (LogStr -> IO ()) -> IO () +printBanner log = do echo " _____ _ _ _____ _ _ _ " echo " | ___| (_) | | ___ | ___| (_) __ _ | |__ | |_ ___ _ __ " echo " | |_ | | | | / _ \\ | |_ | | / _\\`| | '_ \\ | __| / _ \\ | '__|" echo " | _| | | | | | __/ | _| | | | (_| | | | | | | |_ | __/ | | " echo " |_| |_| |_| \\___| |_| |_| \\__, | |_| |_| \\__| \\___| |_| " echo " |___/ " - echo " Version $1 Last updated: $2" + echo $ " Version " <> showVersion version echo " Developed by Gimleux, Valentin, Open-Schnick. " echo " Development Blog: https://blog.filefighter.de " echo " The code can be found at: https://www.github.com/filefighter " echo "" - echo "-------------------------< $3 >---------------------------" + echo "-------------------------< FileHandlerService >---------------------------" echo "" + hFlush stdout where - echo = putStrLn + echo :: String -> IO () + echo msg = log . toLogStr $ msg <> "\n" From 5e61feb34746cda25efcd458021408cd377a57ef Mon Sep 17 00:00:00 2001 From: qvalentin Date: Wed, 12 Oct 2022 18:23:26 +0200 Subject: [PATCH 31/35] Fix delete endpoint --- src/FileStorage.hs | 15 +++++++++- src/Handler/Delete.hs | 13 ++++----- src/KeyStorage.hs | 65 ++++++++++++++++++++++++++----------------- 3 files changed, 59 insertions(+), 34 deletions(-) diff --git a/src/FileStorage.hs b/src/FileStorage.hs index 012880f..fabbcbb 100644 --- a/src/FileStorage.hs +++ b/src/FileStorage.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + -- | module FileStorage where @@ -13,13 +17,22 @@ storeFile :: MonadResource m => Inode -> IO (ConduitT ByteString o m ()) storeFile inode = do let id = fileSystemId inode createDirectoryIfMissing True $ take 1 id - return $sinkFileCautious (getPathFromFileId id) + return $ sinkFileCautious (getPathFromFileId id) retrieveFile :: MonadResource m => Inode -> ConduitT i ByteString m () retrieveFile inode = do let id = fileSystemId inode sourceFile (getPathFromFileId id) +deleteFile :: (MonadLogger m, MonadIO m) => Inode -> m () +deleteFile inode = do + let id = fileSystemId inode + let path = getPathFromFileId id + liftIO (doesFileExist path) + >>= \case + False -> $(logError) $ "Could not delete file with path " <> pack path <> " because it does not exist." + True -> liftIO $ removeFile $ getPathFromFileId id + getPathFromFileId :: String -> String getPathFromFileId id = take 1 id ++ ("/" ++ id) diff --git a/src/Handler/Delete.hs b/src/Handler/Delete.hs index d9c7d8c..2354bde 100644 --- a/src/Handler/Delete.hs +++ b/src/Handler/Delete.hs @@ -7,10 +7,10 @@ import ClassyPrelude hiding (Handler, filter) import Data.Aeson import Data.Maybe (fromMaybe) import qualified Data.Text as DataText -import FileStorage (filterFiles, getPathFromFileId) +import FileStorage (deleteFile, filterFiles, getPathFromFileId) import FileSystemServiceClient.FileSystemServiceClient import Foundation -import KeyStorage (deleteEncKey) +import KeyStorage (deleteEncKey, maybeDeleteKeys) import Models.Inode import Network.HTTP.Req import Network.HTTP.Types @@ -22,13 +22,10 @@ import Prelude (filter) deleteDeleteR :: [Text] -> Handler Value deleteDeleteR path = do - App {fileSystemServiceClient = FileSystemServiceClient {deleteInode = deleteInode}} <- getYesod + App {fileSystemServiceClient = FileSystemServiceClient {deleteInode = deleteInode}, keyEncrptionKey = kek} <- getYesod authToken <- lookupAuth (responseBody, responseStatusCode, responseStatusMessage) <- liftIO $ deleteInode authToken path inodes <- handleApiCall responseBody responseStatusCode responseStatusMessage - liftIO $ mapM_ deleteFile (filter filterFiles inodes) -- Todo: check if file exists - runDB $ mapM_ deleteEncKey inodes + mapM_ deleteFile (filter filterFiles inodes) -- Todo: check if file exists + maybeDeleteKeys kek inodes return responseBody - -deleteFile :: Inode -> IO () -deleteFile file = removeFile $ getPathFromFileId (show $ fileSystemId file) diff --git a/src/KeyStorage.hs b/src/KeyStorage.hs index 433af95..238be3b 100644 --- a/src/KeyStorage.hs +++ b/src/KeyStorage.hs @@ -3,14 +3,11 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -{-# HLINT ignore "Redundant bracket" #-} -- | module KeyStorage where -import ClassyPrelude (Bool (True), ByteString, Handler, IO, Int, Maybe (Just, Nothing), MonadIO (liftIO), Monoid (mempty), ReaderT, Traversable (mapM), any, const, length, maybe, throwIO) +import ClassyPrelude (Bool (True), ByteString, Handler, IO, Int, Maybe (Just, Nothing), MonadIO (liftIO), Monoid (mempty), ReaderT, Traversable (mapM), any, const, length, mapM_, maybe, throwIO) import ClassyPrelude.Yesod (ConduitT, ErrorResponse (NotFound), Filter, MonadHandler, PersistQueryRead (count), PersistStoreRead (get), ResourceT, YesodPersist (YesodPersistBackend, runDB), return, selectList, takeWhileCE, ($)) import ConduitHelper (idC) import Crypto.Cipher.AES (AES256) @@ -27,34 +24,59 @@ import Models.Inode (Inode (Inode, fileSystemId)) import Utils.HandlerUtils (sendInternalError) import Yesod.Core.Types (HandlerContents (HCError), HandlerFor) -getDecryptionFunctionMaybeFromDB :: (YesodPersist site, YesodPersistBackend site ~ MongoContext) => Inode -> Maybe KeyEncryptionKey -> Yesod.Core.Types.HandlerFor site (Inode, ConduitT ByteString ByteString (Yesod.Core.Types.HandlerFor site) ()) -getDecryptionFunctionMaybeFromDB inode kek = do - case kek of - Just kek -> runDB $ getEncKeyOrInternalError inode kek - Nothing -> return (inode, idC) - -maybeCountKeys :: (YesodPersist site, YesodPersistBackend site ~ MongoContext, PersistRecordBackend EncKey MongoContext) => Maybe KeyEncryptionKey -> Yesod.Core.Types.HandlerFor site Int +maybeCountKeys :: + (YesodPersist site, YesodPersistBackend site ~ MongoContext, PersistRecordBackend EncKey MongoContext) => + Maybe KeyEncryptionKey -> + Yesod.Core.Types.HandlerFor site Int maybeCountKeys Nothing = return 0 -maybeCountKeys (Just kek) = do +maybeCountKeys (Just kek) = runDB countEncKeys -countEncKeys :: (MonadIO m, PersistRecordBackend EncKey MongoContext, PersistQueryRead MongoContext) => ReaderT MongoContext m Int +countEncKeys :: + (MonadIO m, PersistRecordBackend EncKey MongoContext, PersistQueryRead MongoContext) => + ReaderT MongoContext m Int countEncKeys = do let filter = [] :: [Filter EncKey] count filter +maybeDeleteKeys :: + (YesodPersist site, YesodPersistBackend site ~ MongoContext, PersistRecordBackend EncKey MongoContext) => + Maybe KeyEncryptionKey -> + [Inode] -> + Yesod.Core.Types.HandlerFor site () +maybeDeleteKeys Nothing inodes = return () +maybeDeleteKeys _ inodes = + runDB $ mapM_ deleteEncKey inodes + +deleteEncKey :: + (MonadHandler m, PersistRecordBackend EncKey MongoContext, PersistQueryRead MongoContext) => + Inode -> + ReaderT MongoContext m () +deleteEncKey inode = + delete (EncKeyKey $ fileSystemId inode) + +getDecryptionFunctionMaybeFromDB :: + (YesodPersist site, YesodPersistBackend site ~ MongoContext) => + Inode -> + Maybe KeyEncryptionKey -> + Yesod.Core.Types.HandlerFor site (Inode, ConduitT ByteString ByteString (Yesod.Core.Types.HandlerFor site) ()) +getDecryptionFunctionMaybeFromDB inode kek = + case kek of + Just kek -> runDB $ getEncKeyOrInternalError inode kek + Nothing -> return (inode, idC) + getEncKeyOrInternalError :: (MonadHandler m, PersistRecordBackend EncKey MongoContext, PersistQueryRead MongoContext) => Inode -> KeyEncryptionKey -> - ReaderT MongoContext m (Inode, (ConduitT ByteString ByteString m ())) + ReaderT MongoContext m (Inode, ConduitT ByteString ByteString m ()) getEncKeyOrInternalError inode kek = do - mres :: (Maybe (EncKey)) <- get $ EncKeyKey (fileSystemId inode) + mres :: (Maybe EncKey) <- get $ EncKeyKey (fileSystemId inode) case mres of Nothing -> sendInternalError - Just (encKey) -> do + Just encKey -> do let key :: AES256 = initCipher $ Key (decryptWithKek kek $ encKeyCipherKey encKey) - let iv = (initIV $ encKeyCipherIv encKey) + let iv = initIV $ encKeyCipherIv encKey return (inode, decryptConduit key iv mempty) storeEncKey :: @@ -67,11 +89,4 @@ storeEncKey inode (Just encKey) = do insertKey dbKey encKey get dbKey return () -storeEncKey inode (Nothing) = return () - -deleteEncKey :: - (MonadHandler m, PersistRecordBackend EncKey MongoContext, PersistQueryRead MongoContext) => - Inode -> - ReaderT MongoContext m () -deleteEncKey inode = do - delete (EncKeyKey $ fileSystemId inode) +storeEncKey inode Nothing = return () From 8050f4523f822d7c744dfb48680e0a5a425fc48c Mon Sep 17 00:00:00 2001 From: qvalentin Date: Sat, 15 Oct 2022 18:05:07 +0200 Subject: [PATCH 32/35] Add MockBackend for integration tests --- package.yaml | 1 + src/Application.hs | 5 +++-- test/MockBackend.hs | 43 +++++++++++++++++++++++++++++++++++++++++++ test/TestImport.hs | 1 - 4 files changed, 47 insertions(+), 3 deletions(-) create mode 100644 test/MockBackend.hs diff --git a/package.yaml b/package.yaml index 6e4ba7a..ff96083 100644 --- a/package.yaml +++ b/package.yaml @@ -36,6 +36,7 @@ dependencies: - mongoDB - template-haskell - fast-logger + - utf8-string # The library contains all of our application code. The executable # defined below is just a thin wrapper. diff --git a/src/Application.hs b/src/Application.hs index de4b158..0d8575b 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -33,7 +33,8 @@ import ClassyPrelude ) import ClassyPrelude.Yesod (Default (def), PersistConfig (createPoolConfig)) import Crypto.KeyEncrptionKey (createKeyEncrptionKey, getOrCreateKekIV) -import Data.ByteString.Char8 (pack) +import Data.ByteString (pack) +import Data.ByteString.UTF8 (fromString) import Data.Yaml.Config (loadYamlSettingsArgs, useEnv) import FileSystemServiceClient.FileSystemServiceClient (makeFileSystemServiceClient) import Foundation @@ -152,7 +153,7 @@ corsPolicy :: String -> Maybe CorsResourcePolicy corsPolicy frontendOrigin = Just CorsResourcePolicy - { corsOrigins = Just ([pack frontendOrigin], True), + { corsOrigins = Just ([fromString frontendOrigin], True), corsMethods = ["GET", "POST", "DELETE"], corsRequestHeaders = ["Authorization", "content-type", "X-FF-IDS", "X-FF-ID", "X-FF-NAME", "X-FF-PATH", "X-FF-SIZE", "X-FF-PARENT-PATH", "X-FF-RELATIVE-PATH", "X-FF-PARENT-PATH"], corsExposedHeaders = Just ["Content-Disposition"], diff --git a/test/MockBackend.hs b/test/MockBackend.hs new file mode 100644 index 0000000..2ffc74f --- /dev/null +++ b/test/MockBackend.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE OverloadedStrings #-} + +module MockBackend where + +import ClassyPrelude +import ClassyPrelude.Yesod (Application, Value) +import Data.Aeson (encode) +import Network.HTTP.Types.Status +import Network.Wai (Request (pathInfo), responseLBS) +import Network.Wai.Handler.Warp (run) + +type MockResponses = [MockResponse] + +type MockResponse = (Text, Value, Status) + +withMockBackend :: MockResponses -> IO () +withMockBackend mockResponses = run 8080 $ makeApp mockResponses + +makeApp :: MockResponses -> Application +makeApp mockResponses req send = do + let path = pathInfo req + case find (isRequestedPath path) mockResponses of + Just mockResponse -> sendMockResponse mockResponse req send + Nothing -> sendNotFoundError req send + +isRequestedPath :: [Text] -> MockResponse -> Bool +isRequestedPath requestedPath (pathToMock, _, _) = pathToMock == intercalate "/" requestedPath + +sendNotFoundError :: Application +sendNotFoundError _ send = do + send $ + responseLBS + status404 + [("Content-Type", "application/json; charset=utf-8")] + "" + +sendMockResponse :: MockResponse -> Application +sendMockResponse (_, value, status) _ send = do + send $ + responseLBS + status + [("Content-Type", "application/json; charset=utf-8")] + (encode value) diff --git a/test/TestImport.hs b/test/TestImport.hs index d9d4c46..5923e5f 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -1,6 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE NoImplicitPrelude #-} module TestImport From c605d27db08f59c286f838cd3d6074426993094a Mon Sep 17 00:00:00 2001 From: qvalentin Date: Fri, 21 Oct 2022 19:11:19 +0200 Subject: [PATCH 33/35] Add Upload test --- config/test-settings.yml | 2 +- src/Models/Inode.hs | 8 +++++ src/Models/User.hs | 13 +++++--- src/Utils/HandlerUtils.hs | 8 +++-- src/Utils/MaybeUtils.hs | 14 +++++++++ test/Handler/UploadSpec.hs | 60 +++++++++++++++++++++++++++++++++++++ test/MockBackend.hs | 22 +++++++++----- test/resources/someFile.txt | 1 + 8 files changed, 113 insertions(+), 15 deletions(-) create mode 100644 src/Utils/MaybeUtils.hs create mode 100644 test/Handler/UploadSpec.hs create mode 100644 test/resources/someFile.txt diff --git a/config/test-settings.yml b/config/test-settings.yml index 13bd3c9..e4042fa 100644 --- a/config/test-settings.yml +++ b/config/test-settings.yml @@ -4,7 +4,7 @@ fileSystemServiceSettings: url: "_env:FILESYSTEMSERVICE_URL:localhost" port: "_env:FILESYSTEMSERVICE_PORT:8080" -encryptionPassword: "_env:ENCRYPTION_PASSWORD:changeThis" +encryptionPassword: "_env:ENCRYPTION_PASSWORD:null" appDatabaseConf: user: root diff --git a/src/Models/Inode.hs b/src/Models/Inode.hs index e3a784b..5b0e5bd 100644 --- a/src/Models/Inode.hs +++ b/src/Models/Inode.hs @@ -36,6 +36,14 @@ instance FromJSON Inode where omitNothingFields = True } +instance ToJSON Inode where + toJSON = + genericToJSON + defaultOptions + { fieldLabelModifier = typeFieldRename, + omitNothingFields = True + } + getFirstPathPiece :: Inode -> String getFirstPathPiece inode = do let inodePath = path inode diff --git a/src/Models/User.hs b/src/Models/User.hs index 406b8d4..3530e9c 100644 --- a/src/Models/User.hs +++ b/src/Models/User.hs @@ -1,8 +1,8 @@ {-# LANGUAGE DeriveGeneric #-} module Models.User where -import ClassyPrelude +import ClassyPrelude import Data.Aeson data User = User @@ -12,14 +12,19 @@ data User = User } deriving (Show, Generic) - -instance ToJSON User - userIdFieldRename :: String -> String userIdFieldRename "userId" = "id" userIdFieldRename "id" = "userId" userIdFieldRename name = name +instance ToJSON User where + toJSON = + genericToJSON + defaultOptions + { fieldLabelModifier = userIdFieldRename, + omitNothingFields = True + } + instance FromJSON User where parseJSON = genericParseJSON diff --git a/src/Utils/HandlerUtils.hs b/src/Utils/HandlerUtils.hs index bb308b1..bd6eeed 100644 --- a/src/Utils/HandlerUtils.hs +++ b/src/Utils/HandlerUtils.hs @@ -18,6 +18,7 @@ import ClassyPrelude Text, Utf8 (decodeUtf8), elem, + fromMaybe, maybe, otherwise, pack, @@ -36,6 +37,7 @@ import Foundation import Models.RestApiStatus import Network.HTTP.Types import Network.Wai (rawPathInfo) +import Utils.MaybeUtils (firstJustsM) import Yesod ( ContentType, MonadHandler (HandlerSite), @@ -43,6 +45,7 @@ import Yesod YesodRequest (reqAccept, reqWaiRequest), getRequest, logError, + lookupBearerAuth, lookupCookie, lookupGetParam, notAuthenticated, @@ -85,9 +88,8 @@ sendErrorOrRedirect status body = lookupAuth :: MonadHandler m => m Text lookupAuth = do - authToken <- lookupCookie "token" - authTokenParam <- lookupGetParam "token" - maybe (maybe notAuthenticated return authTokenParam) return authToken + maybeToken <- firstJustsM [lookupCookie "token", lookupBearerAuth, lookupGetParam "token"] + maybe notAuthenticated return maybeToken lookupContentType :: MonadHandler m => ContentType -> m Bool lookupContentType contentType = diff --git a/src/Utils/MaybeUtils.hs b/src/Utils/MaybeUtils.hs new file mode 100644 index 0000000..113ec09 --- /dev/null +++ b/src/Utils/MaybeUtils.hs @@ -0,0 +1,14 @@ +module Utils.MaybeUtils where + +import Data.Foldable (foldlM) +import Prelude + +-- | Takes computations returnings @Maybes@; tries each one in order. +-- The first one to return a @Just@ wins. Returns @Nothing@ if all computations +-- return @Nothing@. +firstJustsM :: (Monad m, Foldable f) => f (m (Maybe a)) -> m (Maybe a) +firstJustsM = foldlM go Nothing + where + go :: Monad m => Maybe a -> m (Maybe a) -> m (Maybe a) + go Nothing action = action + go result@(Just _) _action = return result diff --git a/test/Handler/UploadSpec.hs b/test/Handler/UploadSpec.hs new file mode 100644 index 0000000..fad76cf --- /dev/null +++ b/test/Handler/UploadSpec.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Handler.UploadSpec (spec) where + +import ClassyPrelude.Yesod (hAuthorization, status200) +import Control.Concurrent (killThread) +import Data.Aeson +import MockBackend (MockResponse (..), withMockBackend) +import Models.Inode (Inode (..)) +import Models.User (User (User, privileges)) +import TestImport + +apiPrefix :: Text +apiPrefix = "api/api" + +preflightMockResponse :: MockResponse +preflightMockResponse = MockResponse {pathToRequest = apiPrefix <> "/filesystem/preflight", returnValue = "", status = status200} + +mockUser :: User +mockUser = User 1 "username" "privileges" + +mockInode :: Inode +mockInode = + Inode + { fileSystemId = "abcd", + name = "somefile.txt", + path = Just "/someFolder/somefile.txt", + mimeType = Just "text", + size = 100, + lastUpdated = 100, + lastUpdatedBy = mockUser + } + +uploadMockResponse :: MockResponse +uploadMockResponse = MockResponse {pathToRequest = apiPrefix <> "/filesystem/upload", returnValue = toJSON [mockInode], status = status200} + +withStubbedApi :: IO () -> IO () +withStubbedApi action = + bracket + (withMockBackend [preflightMockResponse, uploadMockResponse]) + killThread + (const action) + +spec :: Spec +spec = withApp $ + around_ withStubbedApi $ do + describe "Upload endpoint something" $ do + it "Accepts file upload" $ do + request $ do + addFile "file" "./test/resources/someFile.txt" "text/plain" + setUrl UploadR + setMethod "POST" + addRequestHeader (hAuthorization, "Bearer token") + addRequestHeader ("X-FF-RELATIVE-PATH", "somefile.txt") + addRequestHeader ("X-FF-PARENT-PATH", "/someFolder") + statusIs 200 + safedFile <- liftIO $ readFile "./a/abcd" + let expected = "Hallo\n" + assertEq "Filecontent is correct" safedFile expected diff --git a/test/MockBackend.hs b/test/MockBackend.hs index 2ffc74f..9c43224 100644 --- a/test/MockBackend.hs +++ b/test/MockBackend.hs @@ -1,9 +1,13 @@ {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Redundant bracket" #-} module MockBackend where import ClassyPrelude -import ClassyPrelude.Yesod (Application, Value) +import ClassyPrelude.Yesod (Application, Value, object, (.=)) +import Control.Concurrent (ThreadId, forkIO) import Data.Aeson (encode) import Network.HTTP.Types.Status import Network.Wai (Request (pathInfo), responseLBS) @@ -11,10 +15,10 @@ import Network.Wai.Handler.Warp (run) type MockResponses = [MockResponse] -type MockResponse = (Text, Value, Status) +data MockResponse = MockResponse {pathToRequest :: Text, returnValue :: Value, status :: Status} -withMockBackend :: MockResponses -> IO () -withMockBackend mockResponses = run 8080 $ makeApp mockResponses +withMockBackend :: MockResponses -> IO ThreadId +withMockBackend mockResponses = forkIO $ run 8080 $ makeApp mockResponses makeApp :: MockResponses -> Application makeApp mockResponses req send = do @@ -24,18 +28,22 @@ makeApp mockResponses req send = do Nothing -> sendNotFoundError req send isRequestedPath :: [Text] -> MockResponse -> Bool -isRequestedPath requestedPath (pathToMock, _, _) = pathToMock == intercalate "/" requestedPath +isRequestedPath requestedPath (MockResponse {pathToRequest = pathToRequest}) = pathToRequest == intercalate "/" requestedPath sendNotFoundError :: Application sendNotFoundError _ send = do + let response = + object + [ "message" .= ("Endpoint not found" :: String) + ] send $ responseLBS status404 [("Content-Type", "application/json; charset=utf-8")] - "" + (encode response) sendMockResponse :: MockResponse -> Application -sendMockResponse (_, value, status) _ send = do +sendMockResponse (MockResponse {returnValue = value, status = status}) _ send = do send $ responseLBS status diff --git a/test/resources/someFile.txt b/test/resources/someFile.txt new file mode 100644 index 0000000..b5fc21b --- /dev/null +++ b/test/resources/someFile.txt @@ -0,0 +1 @@ +Hallo From 8bc0aa7fb36b0d42d0930286e5571cdde2b39908 Mon Sep 17 00:00:00 2001 From: qvalentin Date: Sun, 23 Oct 2022 17:49:07 +0200 Subject: [PATCH 34/35] Improve upload test --- src/Models/Inode.hs | 2 +- src/Models/User.hs | 3 ++- test/Handler/UploadSpec.hs | 16 ++++++---------- test/MockBackend.hs | 12 ++++++++++-- 4 files changed, 19 insertions(+), 14 deletions(-) diff --git a/src/Models/Inode.hs b/src/Models/Inode.hs index 5b0e5bd..8561434 100644 --- a/src/Models/Inode.hs +++ b/src/Models/Inode.hs @@ -21,7 +21,7 @@ data Inode = Inode lastUpdated :: Int, lastUpdatedBy :: User } - deriving (Show, Generic) + deriving (Show, Generic, Eq) typeFieldRename :: String -> String typeFieldRename "fileSystemId" = "id" diff --git a/src/Models/User.hs b/src/Models/User.hs index 3530e9c..0a974c6 100644 --- a/src/Models/User.hs +++ b/src/Models/User.hs @@ -3,6 +3,7 @@ module Models.User where import ClassyPrelude +import ClassyPrelude (Eq) import Data.Aeson data User = User @@ -10,7 +11,7 @@ data User = User username :: String, privileges :: String } - deriving (Show, Generic) + deriving (Show, Generic, Eq) userIdFieldRename :: String -> String userIdFieldRename "userId" = "id" diff --git a/test/Handler/UploadSpec.hs b/test/Handler/UploadSpec.hs index fad76cf..7b6f84f 100644 --- a/test/Handler/UploadSpec.hs +++ b/test/Handler/UploadSpec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoImplicitPrelude #-} module Handler.UploadSpec (spec) where @@ -6,9 +7,9 @@ module Handler.UploadSpec (spec) where import ClassyPrelude.Yesod (hAuthorization, status200) import Control.Concurrent (killThread) import Data.Aeson -import MockBackend (MockResponse (..), withMockBackend) +import MockBackend (MockResponse (..), MockResponses, withMockBackend, withStubbedApi) import Models.Inode (Inode (..)) -import Models.User (User (User, privileges)) +import Models.User (User (User)) import TestImport apiPrefix :: Text @@ -35,16 +36,9 @@ mockInode = uploadMockResponse :: MockResponse uploadMockResponse = MockResponse {pathToRequest = apiPrefix <> "/filesystem/upload", returnValue = toJSON [mockInode], status = status200} -withStubbedApi :: IO () -> IO () -withStubbedApi action = - bracket - (withMockBackend [preflightMockResponse, uploadMockResponse]) - killThread - (const action) - spec :: Spec spec = withApp $ - around_ withStubbedApi $ do + around_ (withStubbedApi [preflightMockResponse, uploadMockResponse]) $ do describe "Upload endpoint something" $ do it "Accepts file upload" $ do request $ do @@ -58,3 +52,5 @@ spec = withApp $ safedFile <- liftIO $ readFile "./a/abcd" let expected = "Hallo\n" assertEq "Filecontent is correct" safedFile expected + (uploadResponse :: [Inode]) <- requireJSONResponse + assertEq "Response is correct" uploadResponse [mockInode] diff --git a/test/MockBackend.hs b/test/MockBackend.hs index 9c43224..a31291f 100644 --- a/test/MockBackend.hs +++ b/test/MockBackend.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - {-# HLINT ignore "Redundant bracket" #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} module MockBackend where @@ -9,6 +9,7 @@ import ClassyPrelude import ClassyPrelude.Yesod (Application, Value, object, (.=)) import Control.Concurrent (ThreadId, forkIO) import Data.Aeson (encode) +import GHC.Conc (killThread) import Network.HTTP.Types.Status import Network.Wai (Request (pathInfo), responseLBS) import Network.Wai.Handler.Warp (run) @@ -17,6 +18,13 @@ type MockResponses = [MockResponse] data MockResponse = MockResponse {pathToRequest :: Text, returnValue :: Value, status :: Status} +withStubbedApi :: MockResponses -> IO () -> IO () +withStubbedApi mockResponses action = + bracket + (withMockBackend mockResponses) + killThread + (const action) + withMockBackend :: MockResponses -> IO ThreadId withMockBackend mockResponses = forkIO $ run 8080 $ makeApp mockResponses From c875990ae8dd8c70cf3be00186579594c205ec50 Mon Sep 17 00:00:00 2001 From: qvalentin Date: Sun, 6 Nov 2022 17:27:07 +0100 Subject: [PATCH 35/35] Working upload test --- .stylish-haskell.yaml | 379 +++++++++++++++++++++++++++++++++++++ test/Handler/UploadSpec.hs | 59 ++++-- test/MockBackend.hs | 83 ++++++-- 3 files changed, 494 insertions(+), 27 deletions(-) create mode 100644 .stylish-haskell.yaml diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml new file mode 100644 index 0000000..1b52804 --- /dev/null +++ b/.stylish-haskell.yaml @@ -0,0 +1,379 @@ +# stylish-haskell configuration file +# ================================== + +# The stylish-haskell tool is mainly configured by specifying steps. These steps +# are a list, so they have an order, and one specific step may appear more than +# once (if needed). Each file is processed by these steps in the given order. +steps: + # Convert some ASCII sequences to their Unicode equivalents. This is disabled + # by default. + # - unicode_syntax: + # # In order to make this work, we also need to insert the UnicodeSyntax + # # language pragma. If this flag is set to true, we insert it when it's + # # not already present. You may want to disable it if you configure + # # language extensions using some other method than pragmas. Default: + # # true. + # add_language_pragma: true + + # Format module header + # + # Currently, this option is not configurable and will format all exports and + # module declarations to minimize diffs + # + # - module_header: + # # How many spaces use for indentation in the module header. + # indent: 4 + # + # # Should export lists be sorted? Sorting is only performed within the + # # export section, as delineated by Haddock comments. + # sort: true + # + # # See `separate_lists` for the `imports` step. + # separate_lists: true + # + # # When to break the "where". + # # Possible values: + # # - exports: only break when there is an explicit export list. + # # - single: only break when the export list counts more than one export. + # # - inline: only break when the export list is too long. This is + # # determined by the `columns` setting. Not applicable when the export + # # list contains comments as newlines will be required. + # # - always: always break before the "where". + # break_where: exports + # + # # Where to put open bracket + # # Possible values: + # # - same_line: put open bracket on the same line as the module name, before the + # # comment of the module + # # - next_line: put open bracket on the next line, after module comment + # open_bracket: next_line + + # Format record definitions. This is disabled by default. + # + # You can control the layout of record fields. The only rules that can't be configured + # are these: + # + # - "|" is always aligned with "=" + # - "," in fields is always aligned with "{" + # - "}" is likewise always aligned with "{" + # + - records: + # How to format equals sign between type constructor and data constructor. + # Possible values: + # - "same_line" -- leave "=" AND data constructor on the same line as the type constructor. + # - "indent N" -- insert a new line and N spaces from the beginning of the next line. + equals: "indent 2" + + # How to format first field of each record constructor. + # Possible values: + # - "same_line" -- "{" and first field goes on the same line as the data constructor. + # - "indent N" -- insert a new line and N spaces from the beginning of the data constructor + first_field: "indent 2" + + # How many spaces to insert between the column with "," and the beginning of the comment in the next line. + field_comment: 2 + + # How many spaces to insert before "deriving" clause. Deriving clauses are always on separate lines. + deriving: 2 + + # How many spaces to insert before "via" clause counted from indentation of deriving clause + # Possible values: + # - "same_line" -- "via" part goes on the same line as "deriving" keyword. + # - "indent N" -- insert a new line and N spaces from the beginning of "deriving" keyword. + via: "indent 2" + + # Sort typeclass names in the "deriving" list alphabetically. + sort_deriving: true + + # Wheter or not to break enums onto several lines + # + # Default: false + break_enums: true + + # Whether or not to break single constructor data types before `=` sign + # + # Default: true + break_single_constructors: true + + # Whether or not to curry constraints on function. + # + # E.g: @allValues :: Enum a => Bounded a => Proxy a -> [a]@ + # + # Instead of @allValues :: (Enum a, Bounded a) => Proxy a -> [a]@ + # + # Default: false + curried_context: false + + # Align the right hand side of some elements. This is quite conservative + # and only applies to statements where each element occupies a single + # line. + # Possible values: + # - always - Always align statements. + # - adjacent - Align statements that are on adjacent lines in groups. + # - never - Never align statements. + # All default to always. + - simple_align: + cases: always + top_level_patterns: always + records: always + multi_way_if: always + + # Import cleanup + - imports: + # There are different ways we can align names and lists. + # + # - global: Align the import names and import list throughout the entire + # file. + # + # - file: Like global, but don't add padding when there are no qualified + # imports in the file. + # + # - group: Only align the imports per group (a group is formed by adjacent + # import lines). + # + # - none: Do not perform any alignment. + # + # Default: global. + align: global + + # The following options affect only import list alignment. + # + # List align has following options: + # + # - after_alias: Import list is aligned with end of import including + # 'as' and 'hiding' keywords. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # > init, last, length) + # + # - with_alias: Import list is aligned with start of alias or hiding. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # > init, last, length) + # + # - with_module_name: Import list is aligned `list_padding` spaces after + # the module name. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # init, last, length) + # + # This is mainly intended for use with `pad_module_names: false`. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # init, last, length, scanl, scanr, take, drop, + # sort, nub) + # + # - new_line: Import list starts always on new line. + # + # > import qualified Data.List as List + # > (concat, foldl, foldr, head, init, last, length) + # + # - repeat: Repeat the module name to align the import list. + # + # > import qualified Data.List as List (concat, foldl, foldr, head) + # > import qualified Data.List as List (init, last, length) + # + # Default: after_alias + list_align: after_alias + + # Right-pad the module names to align imports in a group: + # + # - true: a little more readable + # + # > import qualified Data.List as List (concat, foldl, foldr, + # > init, last, length) + # > import qualified Data.List.Extra as List (concat, foldl, foldr, + # > init, last, length) + # + # - false: diff-safe + # + # > import qualified Data.List as List (concat, foldl, foldr, init, + # > last, length) + # > import qualified Data.List.Extra as List (concat, foldl, foldr, + # > init, last, length) + # + # Default: true + pad_module_names: true + + # Long list align style takes effect when import is too long. This is + # determined by 'columns' setting. + # + # - inline: This option will put as much specs on same line as possible. + # + # - new_line: Import list will start on new line. + # + # - new_line_multiline: Import list will start on new line when it's + # short enough to fit to single line. Otherwise it'll be multiline. + # + # - multiline: One line per import list entry. + # Type with constructor list acts like single import. + # + # > import qualified Data.Map as M + # > ( empty + # > , singleton + # > , ... + # > , delete + # > ) + # + # Default: inline + long_list_align: inline + + # Align empty list (importing instances) + # + # Empty list align has following options + # + # - inherit: inherit list_align setting + # + # - right_after: () is right after the module name: + # + # > import Vector.Instances () + # + # Default: inherit + empty_list_align: inherit + + # List padding determines indentation of import list on lines after import. + # This option affects 'long_list_align'. + # + # - : constant value + # + # - module_name: align under start of module name. + # Useful for 'file' and 'group' align settings. + # + # Default: 4 + list_padding: 4 + + # Separate lists option affects formatting of import list for type + # or class. The only difference is single space between type and list + # of constructors, selectors and class functions. + # + # - true: There is single space between Foldable type and list of it's + # functions. + # + # > import Data.Foldable (Foldable (fold, foldl, foldMap)) + # + # - false: There is no space between Foldable type and list of it's + # functions. + # + # > import Data.Foldable (Foldable(fold, foldl, foldMap)) + # + # Default: true + separate_lists: true + + # Space surround option affects formatting of import lists on a single + # line. The only difference is single space after the initial + # parenthesis and a single space before the terminal parenthesis. + # + # - true: There is single space associated with the enclosing + # parenthesis. + # + # > import Data.Foo ( foo ) + # + # - false: There is no space associated with the enclosing parenthesis + # + # > import Data.Foo (foo) + # + # Default: false + space_surround: false + + # Post qualify option moves any qualifies found in import declarations + # to the end of the declaration. This also adjust padding for any + # unqualified import declarations. + # + # - true: Qualified as is moved to the end of the + # declaration. + # + # > import Data.Bar + # > import Data.Foo qualified as F + # + # - false: Qualified remains in the default location and unqualified + # imports are padded to align with qualified imports. + # + # > import Data.Bar + # > import qualified Data.Foo as F + # + # Default: false + post_qualify: false + + # Language pragmas + - language_pragmas: + # We can generate different styles of language pragma lists. + # + # - vertical: Vertical-spaced language pragmas, one per line. + # + # - compact: A more compact style. + # + # - compact_line: Similar to compact, but wrap each line with + # `{-# LANGUAGE #-}'. + # + # - vertical_compact: Similar to vertical, but use only one language pragma. + # + # Default: vertical. + style: vertical + + # Align affects alignment of closing pragma brackets. + # + # - true: Brackets are aligned in same column. + # + # - false: Brackets are not aligned together. There is only one space + # between actual import and closing bracket. + # + # Default: true + align: true + + # stylish-haskell can detect redundancy of some language pragmas. If this + # is set to true, it will remove those redundant pragmas. Default: true. + remove_redundant: true + + # Language prefix to be used for pragma declaration, this allows you to + # use other options non case-sensitive like "language" or "Language". + # If a non correct String is provided, it will default to: LANGUAGE. + language_prefix: LANGUAGE + + # Replace tabs by spaces. This is disabled by default. + # - tabs: + # # Number of spaces to use for each tab. Default: 8, as specified by the + # # Haskell report. + # spaces: 8 + + # Remove trailing whitespace + - trailing_whitespace: {} + + # Squash multiple spaces between the left and right hand sides of some + # elements into single spaces. Basically, this undoes the effect of + # simple_align but is a bit less conservative. + # - squash: {} + +# A common setting is the number of columns (parts of) code will be wrapped +# to. Different steps take this into account. +# +# Set this to null to disable all line wrapping. +# +# Default: 80. +columns: 50 + +# By default, line endings are converted according to the OS. You can override +# preferred format here. +# +# - native: Native newline format. CRLF on Windows, LF on other OSes. +# +# - lf: Convert to LF ("\n"). +# +# - crlf: Convert to CRLF ("\r\n"). +# +# Default: native. +newline: native + +# Sometimes, language extensions are specified in a cabal file or from the +# command line instead of using language pragmas in the file. stylish-haskell +# needs to be aware of these, so it can parse the file correctly. +# +# No language extensions are enabled by default. +# language_extensions: +# - TemplateHaskell +# - QuasiQuotes + +# Attempt to find the cabal file in ancestors of the current directory, and +# parse options (currently only language extensions) from that. +# +# Default: true +cabal: true diff --git a/test/Handler/UploadSpec.hs b/test/Handler/UploadSpec.hs index 7b6f84f..de6a11a 100644 --- a/test/Handler/UploadSpec.hs +++ b/test/Handler/UploadSpec.hs @@ -1,22 +1,44 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NoImplicitPrelude #-} module Handler.UploadSpec (spec) where -import ClassyPrelude.Yesod (hAuthorization, status200) -import Control.Concurrent (killThread) -import Data.Aeson -import MockBackend (MockResponse (..), MockResponses, withMockBackend, withStubbedApi) -import Models.Inode (Inode (..)) -import Models.User (User (User)) -import TestImport +import ClassyPrelude.Yesod (hAuthorization, + status200) +import Control.Concurrent (killThread) +import Data.Aeson +import FileSystemServiceClient.FileSystemServiceClient (PreflightInode (..), + UploadedInode (UploadedInode), + relativePath) +import MockBackend (MockResponse (..), + MockResponses, + withMockBackend, + withStubbedApi) +import Models.Inode (Inode (..)) +import Models.Path (Path (Path)) +import Models.User (User (User)) +import TestImport apiPrefix :: Text apiPrefix = "api/api" +preflightExpectedBody :: Value +preflightExpectedBody = + toJSON $ + PreflightInode + { parentPath = Path "/someFolder", + relativePaths = [Path "somefile.txt"] + } + preflightMockResponse :: MockResponse -preflightMockResponse = MockResponse {pathToRequest = apiPrefix <> "/filesystem/preflight", returnValue = "", status = status200} +preflightMockResponse = + MockResponse + { pathToRequest = apiPrefix <> "/filesystem/preflight", + expectedBody = preflightExpectedBody, + returnValue = "", + status = status200 + } mockUser :: User mockUser = User 1 "username" "privileges" @@ -33,8 +55,23 @@ mockInode = lastUpdatedBy = mockUser } +uploadExpectedBody :: Value +uploadExpectedBody = + toJSON $ + UploadedInode + (Path "/someFolder") + (Path "somefile.txt") + 6 + "text/plain" + uploadMockResponse :: MockResponse -uploadMockResponse = MockResponse {pathToRequest = apiPrefix <> "/filesystem/upload", returnValue = toJSON [mockInode], status = status200} +uploadMockResponse = + MockResponse + { pathToRequest = apiPrefix <> "/filesystem/upload", + expectedBody = uploadExpectedBody, + returnValue = toJSON [mockInode], + status = status200 + } spec :: Spec spec = withApp $ diff --git a/test/MockBackend.hs b/test/MockBackend.hs index a31291f..4d99013 100644 --- a/test/MockBackend.hs +++ b/test/MockBackend.hs @@ -1,22 +1,39 @@ {-# LANGUAGE OverloadedStrings #-} -{-# HLINT ignore "Redundant bracket" #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} {-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Redundant bracket" #-} + module MockBackend where -import ClassyPrelude -import ClassyPrelude.Yesod (Application, Value, object, (.=)) -import Control.Concurrent (ThreadId, forkIO) -import Data.Aeson (encode) -import GHC.Conc (killThread) -import Network.HTTP.Types.Status -import Network.Wai (Request (pathInfo), responseLBS) -import Network.Wai.Handler.Warp (run) +import ClassyPrelude +import ClassyPrelude.Yesod (Application, + ToJSON (toJSON), + Value, + object, + (.=)) +import Control.Concurrent (ThreadId, + forkIO) +import Control.Monad.Writer (MonadWriter (tell), + Writer, + runWriter) +import Data.Aeson (encode) +import GHC.Conc (killThread) +import Network.HTTP.Types.Status +import Network.Wai (Request (pathInfo), + responseLBS, + strictRequestBody) +import Network.Wai.Handler.Warp (run) type MockResponses = [MockResponse] -data MockResponse = MockResponse {pathToRequest :: Text, returnValue :: Value, status :: Status} +data MockResponse + = MockResponse + { pathToRequest :: Text + , expectedBody :: Value + , returnValue :: Value + , status :: Status + } withStubbedApi :: MockResponses -> IO () -> IO () withStubbedApi mockResponses action = @@ -31,18 +48,38 @@ withMockBackend mockResponses = forkIO $ run 8080 $ makeApp mockResponses makeApp :: MockResponses -> Application makeApp mockResponses req send = do let path = pathInfo req - case find (isRequestedPath path) mockResponses of - Just mockResponse -> sendMockResponse mockResponse req send - Nothing -> sendNotFoundError req send + case filter (isRequestedPath path) mockResponses of + [] -> sendNotFoundError "requested path wrong" req send + mockResponses -> sendCorrectMockResponse mockResponses req send + +sendCorrectMockResponse :: MockResponses -> Application +sendCorrectMockResponse responses req send = do + bodyText <- (decodeUtf8 . toStrict) <$> strictRequestBody req + putStrLn bodyText + case (runWriter $ getRequestedResponse responses (bodyText)) of + (Just response, _) -> sendMockResponse response req send + (Nothing, log) -> do + sendNotFoundError ("Body wrong, the following value where copared " <> log) req send isRequestedPath :: [Text] -> MockResponse -> Bool isRequestedPath requestedPath (MockResponse {pathToRequest = pathToRequest}) = pathToRequest == intercalate "/" requestedPath -sendNotFoundError :: Application -sendNotFoundError _ send = do +getRequestedResponse :: MockResponses -> Text -> Writer Text (Maybe MockResponse) +getRequestedResponse responses body = do + tell $ "Comparing " <> body + findM (findCorrectBody body) responses + +findCorrectBody :: Text -> MockResponse -> Writer Text Bool +findCorrectBody actualValue mockResponse = do + let current = toStrict $ decodeUtf8 (encode $ expectedBody mockResponse) + tell $ "Comparing with " <> current + return $ actualValue == current + +sendNotFoundError :: Text -> Application +sendNotFoundError message _ send = do let response = object - [ "message" .= ("Endpoint not found" :: String) + [ "message" .= (message) ] send $ responseLBS @@ -57,3 +94,17 @@ sendMockResponse (MockResponse {returnValue = value, status = status}) _ send = status [("Content-Type", "application/json; charset=utf-8")] (encode value) + +-- Searching + +-- | Like 'find', but where the test can be monadic. +-- +-- > findM (Just . isUpper) "teST" == Just (Just 'S') +-- > findM (Just . isUpper) "test" == Just Nothing +-- > findM (Just . const True) ["x",undefined] == Just (Just "x") +findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a) +findM p = foldr (\x -> ifM (p x) (pure $ Just x)) (pure Nothing) + +-- | Like @if@, but where the test can be monadic. +ifM :: Monad m => m Bool -> m a -> m a -> m a +ifM b t f = do b <- b; if b then t else f