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/.gitignore b/.gitignore index 0b4de9a..5cdb5b3 100644 --- a/.gitignore +++ b/.gitignore @@ -1,20 +1,47 @@ -dist -dist-* -cabal-dev -*.o -*.hi +*.aux +kek.iv *.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/ +.hie +1 +2 +3 +4 +5 +client_session_key.aes +keys +mprofile_*.dat +stan.html + 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/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/Dockerfile b/Dockerfile index 8936738..b97af0f 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,13 +1,20 @@ -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 +ENV DB_USERNAME=filehandler +ENV DB_PASSWORD=changeThis +ENV DB_CONTAINER_NAME=db +ENV DB_NAME=filehandler +ENV FRONTEND_ORIGIN=http://localhost:80 -RUN apt-get update && apt-get upgrade -y +RUN apt update && apt install netbase # 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 @@ -18,6 +25,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 \ No newline at end of file +EXPOSE 5000 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..9c4a572 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,473 +1,6 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} +import Foundation +import Application (appMain) +import ClassyPrelude -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 = appMain 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/config/settings.yml b/config/settings.yml new file mode 100644 index 0000000..57e38bd --- /dev/null +++ b/config/settings.yml @@ -0,0 +1,16 @@ +appProfile: "_env:APP_PROFILE:prod" + +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: + user: "_env:DB_USERNAME:filehandler" + password: "_env:DB_PASSWORD:changeThis" + host: "_env:DB_CONTAINER_NAME:localhost" + database: "_env:DB_NAME:filehandler" + connections: 9 diff --git a/config/test-settings.yml b/config/test-settings.yml new file mode 100644 index 0000000..e4042fa --- /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:null" + +appDatabaseConf: + user: root + password: example + host: "localhost" + database: filehandler + connections: 10 diff --git a/docker-compose.yml b/docker-compose.yml new file mode 100644 index 0000000..23896a3 --- /dev/null +++ b/docker-compose.yml @@ -0,0 +1,33 @@ +version: '3.7' + +services: + + mongo: + image: mongo + ports: + - 27017:27017 + networks: + - db + environment: + 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/ + # + +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."); diff --git a/package.yaml b/package.yaml new file mode 100644 index 0000000..ff96083 --- /dev/null +++ b/package.yaml @@ -0,0 +1,70 @@ +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-cors + - wai-extra + - warp + - yaml + - yesod + - yesod-core + - zip + - zip-stream + - persistent + - yesod-persistent + - persistent-mongoDB + - mongoDB + - template-haskell + - fast-logger + - utf8-string + +# 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: + main: Main.hs + source-dirs: app + ghc-options: + - -threaded + - -rtsopts + - -with-rtsopts=-N + + dependencies: + - FileHandlerYesod + +default-extensions: NoImplicitPrelude 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/routes.yesodroutes b/routes.yesodroutes new file mode 100644 index 0000000..243de41 --- /dev/null +++ b/routes.yesodroutes @@ -0,0 +1,7 @@ +/ HomeR GET +/data/download/*[Text] DownloadR GET +/data/upload UploadR POST +/data/delete/+[Text] DeleteR DELETE +/data/preview/*[Text] PreviewR GET +/data/health HealthR GET +/error ErrorR GET diff --git a/src/Application.hs b/src/Application.hs new file mode 100644 index 0000000..0d8575b --- /dev/null +++ b/src/Application.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ViewPatterns #-} + +module Application + ( appMain, + makeFoundation, + makeLogWare, + ) +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, + when, + ($), + (<$>), + (||), + ) +import ClassyPrelude.Yesod (Default (def), PersistConfig (createPoolConfig)) +import Crypto.KeyEncrptionKey (createKeyEncrptionKey, getOrCreateKekIV) +import Data.ByteString (pack) +import Data.ByteString.UTF8 (fromString) +import Data.Yaml.Config (loadYamlSettingsArgs, useEnv) +import FileSystemServiceClient.FileSystemServiceClient (makeFileSystemServiceClient) +import Foundation + ( 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 (Middleware) +import Network.Wai.Handler.Warp (run) +import Network.Wai.Middleware.Cors + ( CorsResourcePolicy + ( CorsResourcePolicy, + corsExposedHeaders, + corsIgnoreFailures, + corsMaxAge, + corsMethods, + corsOrigins, + corsRequestHeaders, + corsRequireOrigin, + corsVaryOrigin + ), + 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, frontendOrigin), + configSettingsYmlValue, + ) +import System.Log.FastLogger + ( defaultBufSize, + newStdoutLoggerSet, + toLogStr, + ) +import Utils.FileFighterBanner (printBanner) +import Yesod.Core (mkYesodDispatch, toWaiApp) +import Yesod.Core.Types (Logger (loggerSet), loggerPutStr) +import Yesod.Default.Config2 (makeYesodLogger) + +mkYesodDispatch "App" resourcesApp + +makeFoundation :: AppSettings -> IO App +makeFoundation appSettings = do + let fssC = makeFileSystemServiceClient (fileSystemServiceSettings appSettings) + let maybeEncryptionPassword = case encryptionPassword appSettings of + Just "null" -> Nothing + Nothing -> Nothing + Just password -> Just password + + iv <- if isJust maybeEncryptionPassword then getOrCreateKekIV else return "FallBackIV" + 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 + App + { appSettings = appSettings, + appConnPool = appConnPool, + fileSystemServiceClient = fssC, + 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 () +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 + + application <- toWaiApp app + + run 5000 $ cors (const $ corsPolicy $ frontendOrigin settings) application + +corsPolicy :: String -> Maybe CorsResourcePolicy +corsPolicy frontendOrigin = + Just + CorsResourcePolicy + { 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"], + corsMaxAge = Just $ 60 * 60 * 24, -- one day + corsVaryOrigin = False, + corsRequireOrigin = False, + corsIgnoreFailures = False + } 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 new file mode 100644 index 0000000..302fda3 --- /dev/null +++ b/src/Crypto/CryptoConduit.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +module Crypto.CryptoConduit where + +import ClassyPrelude + ( ByteString, + Integral (div), + IsSequence (drop, splitAt), + Maybe (Just, Nothing), + Monad (return, (>>=)), + MonadIO, + Num ((*), (+), (-)), + Ord (max), + Semigroup ((<>)), + error, + fromMaybe, + length, + maybe, + null, + ($), + (.), + ) +import ClassyPrelude.Conduit + ( 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, cbcDecrypt, cbcEncrypt), + IV, + makeIV, + ) +import Crypto.Data.Padding + +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 + +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/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..f5dad65 --- /dev/null +++ b/src/Crypto/KeyEncrptionKey.hs @@ -0,0 +1,75 @@ +{-# 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.Init (initCipher, initIV) +import Crypto.KDF.BCryptPBKDF (Parameters (Parameters), generate) +import Crypto.RandomGen (genRandomIV) +import Crypto.Types (Key (Key)) +import Data.ByteArray +import FileStorage (getPathFromFileId) +import Models.Inode +import System.Directory (doesFileExist) + +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 ("keys/" <> getPathFromFileId (show $ fileSystemId inode) ++ ".key") + iv <- readFile ("keys/" <> getPathFromFileId (show $ fileSystemId inode) ++ ".iv") + + return (initCipher $ Key key, initIV iv) diff --git a/src/Crypto/RandomGen.hs b/src/Crypto/RandomGen.hs new file mode 100644 index 0000000..c943ea1 --- /dev/null +++ b/src/Crypto/RandomGen.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-deprecations #-} + +-- | +module Crypto.RandomGen where + +import ClassyPrelude +import Crypto.Cipher.Types +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 _ = 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/DBModels.hs b/src/DBModels.hs new file mode 100644 index 0000000..3dea01f --- /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 + Id String + cipherKey ByteString + cipherIv ByteString + deriving Show +|] diff --git a/src/FileStorage.hs b/src/FileStorage.hs new file mode 100644 index 0000000..fabbcbb --- /dev/null +++ b/src/FileStorage.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | +module FileStorage where + +import ClassyPrelude +import ClassyPrelude.Yesod +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 = fileSystemId inode + createDirectoryIfMissing True $ take 1 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) + +getInodeModifcationTime :: Inode -> IO UTCTime +getInodeModifcationTime inode = + let id = fileSystemId inode + in getModificationTime (getPathFromFileId id) + +filterFiles :: Inode -> Bool +filterFiles file = case mimeType file of + Nothing -> False + _ -> True diff --git a/src/FileSystemServiceClient/FileSystemServiceClient.hs b/src/FileSystemServiceClient/FileSystemServiceClient.hs new file mode 100644 index 0000000..dbaf24f --- /dev/null +++ b/src/FileSystemServiceClient/FileSystemServiceClient.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +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 + ( 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 + +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 -> Path -> IO (Value, Int, ByteString), + getInodeContent :: Text -> Path -> IO (Value, Int, ByteString) + } + +data UploadedInode = UploadedInode + { parentPath :: Path, + relativePath :: Path, + size :: Integer, + mimeType :: String + } + deriving (Show, Generic) + +instance ToJSON UploadedInode + +data PreflightInode = PreflightInode + { parentPath :: Path, + relativePaths :: [Path] + } + deriving (Show, Generic) + +instance ToJSON PreflightInode + +httpConfigDontCheckResponse :: p1 -> p2 -> p3 -> Maybe a +httpConfigDontCheckResponse _ _ _ = Nothing + +makeFileSystemServiceClient :: FileSystemServiceSettings -> FileSystemServiceClient +makeFileSystemServiceClient fileSystemServiceSettings = + FileSystemServiceClient + { deleteInode = makeDeleteInode fileSystemServiceSettings, + createInode = makeCreateInode fileSystemServiceSettings, + preflightInode = makePreflightInode fileSystemServiceSettings, + getInodeInfo = makeGetInodeInfo fileSystemServiceSettings, + getInodeContent = makeGetInodeContent fileSystemServiceSettings + } + +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" /: "api" /: "filesystem" /: "delete") + NoReqBody + jsonResponse + ( 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 r@FileSystemServiceSettings {url = url, port = port} authorization uploadedInode = runReq (defaultHttpConfig {httpConfigCheckResponse = httpConfigDontCheckResponse}) $ do + r <- + req + POST -- method + (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 + return (responseBody r, responseStatusCode r, responseStatusMessage r) + +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" /: "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 -> 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) /: "api" /: "api" /: "filesystem" /: "info") + NoReqBody -- use built-in options or add your own + 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) + +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) /: "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 + ( 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/Foundation.hs b/src/Foundation.hs new file mode 100644 index 0000000..9844653 --- /dev/null +++ b/src/Foundation.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module Foundation where + +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 (appDatabaseConf)) +import Yesod.Core + ( FileUpload (FileUploadDisk), + RenderRoute (renderRoute), + Yesod (fileUpload, maximumContentLength), + mkYesodData, + parseRoutesFile, + ) +import Yesod.Core.Types +import Yesod.Persist.Core (YesodPersist (..)) + +data App = App + { appSettings :: AppSettings, + appConnPool :: ConnectionPool, + fileSystemServiceClient :: FileSystemServiceClient, + keyEncrptionKey :: Maybe KeyEncryptionKey, + appLogger :: Logger + } + +mkYesodData "App" $(parseRoutesFile "routes.yesodroutes") + +instance Yesod App where + 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/Delete.hs b/src/Handler/Delete.hs new file mode 100644 index 0000000..2354bde --- /dev/null +++ b/src/Handler/Delete.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +module Handler.Delete where + +import ClassyPrelude hiding (Handler, filter) +import Data.Aeson +import Data.Maybe (fromMaybe) +import qualified Data.Text as DataText +import FileStorage (deleteFile, filterFiles, getPathFromFileId) +import FileSystemServiceClient.FileSystemServiceClient +import Foundation +import KeyStorage (deleteEncKey, maybeDeleteKeys) +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 +deleteDeleteR path = do + App {fileSystemServiceClient = FileSystemServiceClient {deleteInode = deleteInode}, keyEncrptionKey = kek} <- getYesod + authToken <- lookupAuth + (responseBody, responseStatusCode, responseStatusMessage) <- liftIO $ deleteInode authToken path + inodes <- handleApiCall responseBody responseStatusCode responseStatusMessage + mapM_ deleteFile (filter filterFiles inodes) -- Todo: check if file exists + maybeDeleteKeys kek inodes + return responseBody diff --git a/src/Handler/Download.hs b/src/Handler/Download.hs new file mode 100644 index 0000000..35cfa94 --- /dev/null +++ b/src/Handler/Download.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE GADTs #-} +{-# HLINT ignore "Use join" #-} +{-# HLINT ignore "Redundant bracket" #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Unused LANGUAGE pragma" #-} + +module Handler.Download where + +import ClassyPrelude + ( 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, + const, + defaultTimeLocale, + fromMaybe, + id, + join, + map, + maybe, + pack, + parseTimeM, + pure, + putStrLn, + readFile, + tshow, + unpack, + void, + zip, + zipWith, + ($), + (++), + (.), + (<$>), + (<>), + (=<<), + ) +import ClassyPrelude.Yesod + ( ConduitM, + ConduitT, + Entity (Entity), + MonadHandler, + MonadResource, + PersistQueryRead (selectFirst), + PersistUniqueRead (getBy), + ResourceT, + ToJSON (toJSON), + TypedContent, + Value, + YesodPersist (runDB), + addHeader, + awaitForever, + getYesod, + invalidArgs, + lookupGetParam, + respondSource, + runConduit, + runConduitRes, + selectKeys, + sendChunkBS, + sendFile, + sinkFile, + status400, + takeWhileCE, + 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 DBModels (EncKey (EncKey, encKeyCipherIv, encKeyCipherKey)) +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 + ( FileSystemServiceClient, + getInodeContent + ), + UploadedInode (parentPath), + ) +import Foundation (App (App, fileSystemServiceClient, keyEncrptionKey), Handler) +import KeyStorage (getDecryptionFunctionMaybeFromDB, 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, 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 +getDownloadR path = do + App {fileSystemServiceClient = FileSystemServiceClient {getInodeContent = getInodeContent}, keyEncrptionKey = kek} <- getYesod + bearerToken <- lookupAuth + + paths <- lookupPaths path + + apiResponses <- + liftIO $ + mapM + ( \path -> do + (responseBody, responseStatusCode, responseStatusMessage) <- getInodeContent bearerToken path + return (responseBody, responseStatusCode, responseStatusMessage) + ) + paths + + inodes <- + concat <$> mapM handleApiCall' apiResponses + + case inodes of + [] -> sendErrorOrRedirect status400 $ toJSON $ RestApiStatus "Can not download a empty folder." "Bad Request" + [singleInode] -> do + $(logInfo) $ pack $ "Dowload of Inode " <> show singleInode + (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 + .| decFunc + .| awaitForever sendChunkBS + first : moreInodes -> do + let archiveName = getFirstPathPiece first + addHeader "Content-Disposition" ("attachment; filename=\"" ++ pack archiveName ++ ".zip" ++ "\"") + 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 +justOrInternalError (Just a) = return a +justOrInternalError Nothing = sendInternalError + +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 :: FilePath -> IO FilePath +makeAllocateResource = return + +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/Error.hs b/src/Handler/Error.hs new file mode 100644 index 0000000..62303f8 --- /dev/null +++ b/src/Handler/Error.hs @@ -0,0 +1,8 @@ +-- | + +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 new file mode 100644 index 0000000..a83456f --- /dev/null +++ b/src/Handler/Health.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +module Handler.Health where + +import ClassyPrelude + ( FilePath, + Generic, + IO, + Int, + Integer, + IsSequence (filterM), + Maybe, + MonadIO (liftIO), + Show, + String, + Traversable (mapM), + concat, + length, + map, + sum, + ($), + (<$>), + (), + (=<<), + ) +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, + getFileSize, + listDirectory, + ) +import Yesod.Core + +data HealthInfo = HealthInfo + { version :: String, + deploymentType :: String, + actualFilesSize :: Integer, + fileCount :: Int, + keyCount :: Int + } + deriving (Show, Generic) + +instance ToJSON HealthInfo + +getHealthR :: Handler Value +getHealthR = do + 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 = showVersion BuildInfo.version, + deploymentType = deploymentType, + actualFilesSize = actualFilesSize, + fileCount = length files, + keyCount = keyCount + } + returnJson response + +listDirectoryRelative :: FilePath -> IO [FilePath] +listDirectoryRelative x = map (x ) <$> listDirectory x diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs new file mode 100644 index 0000000..ed76aab --- /dev/null +++ b/src/Handler/Home.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Handler.Home where + +import ClassyPrelude hiding (Handler) +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 + return "root Endpoint of the FileHandler Api, you should not have got here." diff --git a/src/Handler/Preview.hs b/src/Handler/Preview.hs new file mode 100644 index 0000000..a32ac92 --- /dev/null +++ b/src/Handler/Preview.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Handler.Preview where + +import ClassyPrelude + ( Bool (True), + Int, + MonadIO (liftIO), + Monoid (mempty), + Show (show), + String, + Text, + fromMaybe, + intercalate, + map, + ($), + (.), + (<>), + ) +import ClassyPrelude.Yesod + ( 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 (filterFiles, retrieveFile) +import FileSystemServiceClient.FileSystemServiceClient (FileSystemServiceClient (getInodeContent)) +import FileSystemServiceClient.FileSystemServiceClient hiding (mimeType) +import Foundation +import KeyStorage (getDecryptionFunctionMaybeFromDB, getEncKeyOrInternalError) +import Models.Inode +import Models.Path (fromMultiPiece) +import Models.RestApiStatus (RestApiStatus (RestApiStatus)) +import Utils.HandlerUtils + ( handleApiCall, + lookupAuth, + sendErrorOrRedirect, + ) + +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 + (inode, decryptFunc) <- getDecryptionFunctionMaybeFromDB inode kek + respondSource (S8.pack $ fromMaybe "application/octet-stream" (mimeType inode)) $ + retrieveFile inode + .| 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 new file mode 100644 index 0000000..37e4352 --- /dev/null +++ b/src/Handler/Upload.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# 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 #-} + +{-# HLINT ignore "Redundant bracket" #-} + +-- | +module Handler.Upload where + +import ClassyPrelude + ( Applicative ((<*>)), + Bool (True), + ByteString, + Eq ((/=)), + IO, + Integer, + IsSequence (filter), + Maybe (..), + Monad (return, (>>=)), + MonadIO (liftIO), + Monoid (mempty), + Show (show), + Text, + id, + pack, + singleton, + undefined, + ($), + (.), + (<$>), + ) +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) +import Crypto.CryptoConduit (encryptConduit) +import Crypto.Error +import Crypto.Init +import Crypto.KeyEncrptionKey hiding (initCipher, initIV) +import Crypto.RandomGen +import Crypto.Types +import DBModels (EncKey (EncKey), EntityField (EncKeyId), Key (EncKeyKey)) +import Data.Aeson + ( Result (Error, Success), + Value, + fromJSON, + object, + ) +import Data.ByteArray hiding (pack, take) +import qualified Data.ByteString.Char8 as S8 +import Data.CaseInsensitive (mk) +import qualified Data.Text as Text +import FileStorage (filterFiles, getPathFromFileId, storeFile) +import FileSystemServiceClient.FileSystemServiceClient + ( FileSystemServiceClient (FileSystemServiceClient, createInode, preflightInode), + PreflightInode (PreflightInode), + 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)) +import System.Directory (createDirectoryIfMissing, doesDirectoryExist) +import UnliftIO.Resource +import Utils.HandlerUtils +import Yesod (YesodPersist (runDB)) +import Yesod.Core + ( FileInfo, + MonadHandler, + MonadIO (liftIO), + fileSource, + getYesod, + invalidArgs, + logDebug, + lookupBearerAuth, + lookupHeader, + notAuthenticated, + runRequestBody, + sendResponseStatus, + ) +import Yesod.Core.Handler (sendResponseCreated) +import Yesod.Core.Types (FileInfo (fileSourceRaw), loggerPutStr) +import Prelude (Bool (True), const, read) + +postUploadR :: Handler Value +postUploadR = do + 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 + lookupUploadedInode file >>= \case + Nothing -> invalidArgs ["Missing required Header."] + Just inode -> do + (responseBody, responseStatusCode, responseStatusMessage) <- liftIO $ createInode authToken inode + createdInodes <- handleApiCall responseBody responseStatusCode responseStatusMessage + $(logInfo) $ pack $ show createdInodes + case filter filterFiles createdInodes of + [singleInode] -> do + (alloc, encKey') <- liftIO $ makeAllocateResource kek singleInode + 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 () +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) + relativePath <- lookupHeader $ Data.CaseInsensitive.mk "X-FF-RELATIVE-PATH" + parentPath <- lookupHeader $ Data.CaseInsensitive.mk "X-FF-PARENT-PATH" + 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 :: 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 $ 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 -> (ConduitT ByteString ByteString (ResourceT IO) ()) -> IO () +makeFreeResource fileInfo inode encryptFunc = do + fileDest <- storeFile inode + runConduitRes $ + fileSource fileInfo + .| encryptFunc + .| fileDest diff --git a/src/KeyStorage.hs b/src/KeyStorage.hs new file mode 100644 index 0000000..238be3b --- /dev/null +++ b/src/KeyStorage.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +module KeyStorage where + +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) +import Crypto.Cipher.Types (IV) +import Crypto.CryptoConduit (decryptConduit) +import Crypto.Init (initCipher, initIV) +import Crypto.KeyEncrptionKey (KeyEncryptionKey, decryptWithKek) +import Crypto.Types (Key (Key)) +import DBModels (EncKey (EncKey, encKeyCipherIv, encKeyCipherKey), Key (EncKeyKey)) +import Database.Persist (Entity, PersistRecordBackend, PersistStoreWrite (insertKey)) +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) +import Yesod.Core.Types (HandlerContents (HCError), HandlerFor) + +maybeCountKeys :: + (YesodPersist site, YesodPersistBackend site ~ MongoContext, PersistRecordBackend EncKey MongoContext) => + Maybe KeyEncryptionKey -> + Yesod.Core.Types.HandlerFor site Int +maybeCountKeys Nothing = return 0 +maybeCountKeys (Just kek) = + runDB countEncKeys + +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 ()) +getEncKeyOrInternalError inode kek = do + mres :: (Maybe EncKey) <- get $ EncKeyKey (fileSystemId inode) + case mres of + Nothing -> sendInternalError + Just encKey -> do + let key :: AES256 = initCipher $ Key (decryptWithKek kek $ encKeyCipherKey encKey) + let iv = initIV $ encKeyCipherIv encKey + return (inode, decryptConduit key iv mempty) + +storeEncKey :: + (MonadIO m, PersistRecordBackend EncKey MongoContext) => + Inode -> + Maybe EncKey -> + ReaderT MongoContext m () +storeEncKey inode (Just encKey) = do + let dbKey = EncKeyKey (fileSystemId inode) + insertKey dbKey encKey + get dbKey + return () +storeEncKey inode Nothing = return () 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..af2ee22 --- /dev/null +++ b/src/Logger.hs @@ -0,0 +1,9 @@ +-- | + +module Logger where +import ClassyPrelude + +logStdOut :: Text -> 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..8561434 --- /dev/null +++ b/src/Models/Inode.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Redundant bracket" #-} + +module Models.Inode where + +import ClassyPrelude +import Data.Aeson +import Data.Text as T (pack, splitOn, unpack) +import Models.Path (Path) +import Models.User + +data Inode = Inode + { fileSystemId :: String, + name :: String, + path :: Maybe String, + mimeType :: Maybe String, + size :: Int, + lastUpdated :: Int, + lastUpdatedBy :: User + } + deriving (Show, Generic, Eq) + +typeFieldRename :: String -> String +typeFieldRename "fileSystemId" = "id" +typeFieldRename "id" = "fileSystemId" +typeFieldRename name = name + +instance FromJSON Inode where + parseJSON = + genericParseJSON + defaultOptions + { fieldLabelModifier = typeFieldRename, + omitNothingFields = True + } + +instance ToJSON Inode where + toJSON = + genericToJSON + defaultOptions + { 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/Models/Path.hs b/src/Models/Path.hs new file mode 100644 index 0000000..95776ab --- /dev/null +++ b/src/Models/Path.hs @@ -0,0 +1,45 @@ +-- | + +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +module Models.Path where +import ClassyPrelude + ( otherwise, + ($), + Show, + Generic, + Semigroup((<>)), + unpack, + String, + ByteString, + Text, + intercalate, + isPrefixOf) +import ClassyPrelude.Yesod ( ToJSON(toJSON) ) +import Data.ByteString.Char8 (pack) + + + +newtype Path = Path { + path :: String + } + deriving (Show, Generic) + + + +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 + | otherwise = "/" <> path diff --git a/src/Models/RestApiStatus.hs b/src/Models/RestApiStatus.hs new file mode 100644 index 0000000..5ecc991 --- /dev/null +++ b/src/Models/RestApiStatus.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DeriveGeneric #-} +-- | + + +module Models.RestApiStatus where + +import ClassyPrelude + +import Data.Aeson + +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..0a974c6 --- /dev/null +++ b/src/Models/User.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Models.User where + +import ClassyPrelude +import ClassyPrelude (Eq) +import Data.Aeson + +data User = User + { userId :: Int, + username :: String, + privileges :: String + } + deriving (Show, Generic, Eq) + +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 + defaultOptions + { fieldLabelModifier = userIdFieldRename, + omitNothingFields = True + } diff --git a/src/Settings.hs b/src/Settings.hs new file mode 100644 index 0000000..fa5d881 --- /dev/null +++ b/src/Settings.hs @@ -0,0 +1,100 @@ +{-# 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 (..), + fromJSON, + withObject, + (.!=), + (.:?), + ) +import Data.FileEmbed (embedFile) +import Data.Yaml (decodeEither') +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) + +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 :: 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, Show) + +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/FileFighterBanner.hs b/src/Utils/FileFighterBanner.hs new file mode 100644 index 0000000..b247aea --- /dev/null +++ b/src/Utils/FileFighterBanner.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +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 :: (LogStr -> IO ()) -> IO () +printBanner log = do + echo " _____ _ _ _____ _ _ _ " + echo " | ___| (_) | | ___ | ___| (_) __ _ | |__ | |_ ___ _ __ " + echo " | |_ | | | | / _ \\ | |_ | | / _\\`| | '_ \\ | __| / _ \\ | '__|" + echo " | _| | | | | | __/ | _| | | | (_| | | | | | | |_ | __/ | | " + echo " |_| |_| |_| \\___| |_| |_| \\__, | |_| |_| \\__| \\___| |_| " + echo " |___/ " + 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 "-------------------------< FileHandlerService >---------------------------" + echo "" + hFlush stdout + where + echo :: String -> IO () + echo msg = log . toLogStr $ msg <> "\n" diff --git a/src/Utils/HandlerUtils.hs b/src/Utils/HandlerUtils.hs new file mode 100644 index 0000000..bd6eeed --- /dev/null +++ b/src/Utils/HandlerUtils.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- | +module Utils.HandlerUtils where + +import ClassyPrelude + ( Bool (..), + ByteString, + Int, + Monad (return, (>>=)), + MonadIO (liftIO), + Ord ((<), (<=)), + Show (show), + Text, + Utf8 (decodeUtf8), + elem, + fromMaybe, + maybe, + otherwise, + pack, + putStr, + putStrLn, + unpack, + ($), + (&&), + (.), + (<$>), + (<>), + ) +import Data.Aeson +import qualified Data.Text as Text +import Foundation +import Models.RestApiStatus +import Network.HTTP.Types +import Network.Wai (rawPathInfo) +import Utils.MaybeUtils (firstJustsM) +import Yesod + ( ContentType, + MonadHandler (HandlerSite), + RedirectUrl, + YesodRequest (reqAccept, reqWaiRequest), + getRequest, + logError, + lookupBearerAuth, + 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 = + case fromJSON body of + Success value -> + return value + Error e -> do + $(logError) $ pack e + sendInternalError + | 400 <= statusCode && statusCode < 500 = do + $(logError) $ pack ("4XX domain error. StatusCode: " <> show statusCode <> " StatusMessage: ") <> decodeUtf8 statusMessage + sendErrorOrRedirect (Status statusCode statusMessage) body --sendResponseStatus (Status statusCode statusMessage) body + | otherwise = do + $(logError) $ pack $ show body + 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 + maybeToken <- firstJustsM [lookupCookie "token", lookupBearerAuth, lookupGetParam "token"] + maybe notAuthenticated return maybeToken + +lookupContentType :: MonadHandler m => ContentType -> m Bool +lookupContentType contentType = + elem contentType . reqAccept <$> getRequest 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/src/Utils/ZipFile.hs b/src/Utils/ZipFile.hs new file mode 100644 index 0000000..bc45fd8 --- /dev/null +++ b/src/Utils/ZipFile.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Redundant bracket" #-} + +-- | +module Utils.ZipFile where + +import ClassyPrelude +import ClassyPrelude.Conduit +import Codec.Archive.Zip.Conduit.Zip +import Crypto.Cipher.AES +import Crypto.Cipher.Types +import Crypto.CryptoConduit (DecFunc, decryptConduit) +import Data.Time +import FileStorage (getInodeModifcationTime, retrieveFile) +import qualified Models.Inode + +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 + 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 + let entry = + ZipEntry + { zipEntryName = Right $ fromString nameInZip, + zipEntryTime = utcToLocalTime timeZone timeStamp, + zipEntrySize = Nothing, -- Just (fromIntegral size'), + zipEntryExternalAttributes = Nothing + } + + yield (entry, ZipDataSource $ retrieveFile currentInode .| decryptFunc) + 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 + parseTimeM True defaultTimeLocale "%s" (show ts) :: Maybe UTCTime diff --git a/stack.yaml b/stack.yaml index c5ef460..ef9dffd 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/24.yaml # User packages to be built. # Various formats can be used as shown in the example below. @@ -30,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: @@ -40,24 +40,9 @@ 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: + - 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: {} @@ -69,7 +54,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 @@ -81,3 +66,4 @@ packages: # # Allow a newer minor version of GHC than the snapshot specifies # compiler-check: newer-minor + diff --git a/stack.yaml.lock b/stack.yaml.lock index 9d3217f..5f376bc 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -3,11 +3,25 @@ # For more information, please see the documentation at: # https://docs.haskellstack.org/en/stable/lock_files -packages: [] +packages: +- completed: + 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: - size: 565266 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/5.yaml - sha256: 78e8ebabf11406261abbc95b44f240acf71802630b368888f6d758de7fc3a2f7 + 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/17/5.yaml + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/24.yaml 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 new file mode 100644 index 0000000..7730858 --- /dev/null +++ b/test/Handler/CommonSpec.hs @@ -0,0 +1,10 @@ +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/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/Handler/UploadSpec.hs b/test/Handler/UploadSpec.hs new file mode 100644 index 0000000..de6a11a --- /dev/null +++ b/test/Handler/UploadSpec.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Handler.UploadSpec (spec) where + +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", + expectedBody = preflightExpectedBody, + 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 + } + +uploadExpectedBody :: Value +uploadExpectedBody = + toJSON $ + UploadedInode + (Path "/someFolder") + (Path "somefile.txt") + 6 + "text/plain" + +uploadMockResponse :: MockResponse +uploadMockResponse = + MockResponse + { pathToRequest = apiPrefix <> "/filesystem/upload", + expectedBody = uploadExpectedBody, + returnValue = toJSON [mockInode], + status = status200 + } + +spec :: Spec +spec = withApp $ + around_ (withStubbedApi [preflightMockResponse, uploadMockResponse]) $ 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 + (uploadResponse :: [Inode]) <- requireJSONResponse + assertEq "Response is correct" uploadResponse [mockInode] diff --git a/test/MockBackend.hs b/test/MockBackend.hs new file mode 100644 index 0000000..4d99013 --- /dev/null +++ b/test/MockBackend.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Redundant bracket" #-} + +module MockBackend where + +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 + , expectedBody :: Value + , 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 + +makeApp :: MockResponses -> Application +makeApp mockResponses req send = do + let path = pathInfo req + 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 + +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" .= (message) + ] + send $ + responseLBS + status404 + [("Content-Type", "application/json; charset=utf-8")] + (encode response) + +sendMockResponse :: MockResponse -> Application +sendMockResponse (MockResponse {returnValue = value, status = status}) _ send = do + send $ + responseLBS + 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 diff --git a/test/Spec.hs b/test/Spec.hs index 7df5105..a824f8c 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,18 +1 @@ -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 +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/TestImport.hs b/test/TestImport.hs new file mode 100644 index 0000000..5923e5f --- /dev/null +++ b/test/TestImport.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# 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." 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 0000000..17cca1a Binary files /dev/null and b/test/resources/key differ 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