diff --git a/.github/workflows/featureRelease.yml b/.github/workflows/featureRelease.yml new file mode 100644 index 0000000..46ad3fd --- /dev/null +++ b/.github/workflows/featureRelease.yml @@ -0,0 +1,37 @@ +name: Feature Release + +on: + workflow_dispatch: + push: + branches: + - 'featureWithPipeline/**' + paths: + - 'app/**' + - 'src/**' + - 'test/**' + +jobs: + Build_Docker_Image_on_Push: + runs-on: ubuntu-latest + steps: + - + name: Set up Project + uses: actions/checkout@v2 + - + name: Build Filehandler + run: | + stack build + + - + name: Login to DockerHub + uses: docker/login-action@v1 + with: + username: ${{ secrets.DOCKER_USER }} + password: ${{ secrets.DOCKER_PW }} + - + name: Build and push + run: | + BINLOCATION=$(stack path --local-install-root) + BINLOCATION=$(realpath --relative-to=. $BINLOCATION) + docker build -t filefighter/filehandler:feature . --build-arg BINLOCATION=$BINLOCATION + docker push filefighter/filehandler:feature \ No newline at end of file diff --git a/.github/workflows/latestRelease.yml b/.github/workflows/latestRelease.yml new file mode 100644 index 0000000..8663d34 --- /dev/null +++ b/.github/workflows/latestRelease.yml @@ -0,0 +1,40 @@ +name: Latest Release + +on: + workflow_dispatch: + push: + branches: "master" + paths: + - 'app/**' + - 'src/**' + - 'test/**' + +jobs: + Build_Docker_Image_on_Push: + runs-on: ubuntu-latest + steps: + - + name: Set up Project + uses: actions/checkout@v2 + - + name: Build Filehandler + run: | + stack build + + - + name: Login to DockerHub + uses: docker/login-action@v1 + with: + username: ${{ secrets.DOCKER_USER }} + password: ${{ secrets.DOCKER_PW }} + - + name: Build and push + run: | + BINLOCATION=$(stack path --local-install-root) + BINLOCATION=$(realpath --relative-to=. $BINLOCATION) + docker build -t filefighter/filehandler:latest . --build-arg BINLOCATION=$BINLOCATION + docker push filefighter/filehandler:latest + - + name: Trigger update on server + run: + - curl -u ${{ secrets.LOG_CREDS }} https://logs.filefighter.de/filefighter-update.log \ No newline at end of file diff --git a/.github/workflows/stableRelease.yml b/.github/workflows/stableRelease.yml new file mode 100644 index 0000000..965f90f --- /dev/null +++ b/.github/workflows/stableRelease.yml @@ -0,0 +1,34 @@ +name: Stable Release + +on: + push: + tags: + - 'v*.*.*' + +jobs: + Build_Docker_Image_on_Push: + runs-on: ubuntu-latest + steps: + - + name: Set up Project + uses: actions/checkout@v2 + - + name: Build Filehandler + run: | + stack build + + - + name: Login to DockerHub + uses: docker/login-action@v1 + with: + username: ${{ secrets.DOCKER_USER }} + password: ${{ secrets.DOCKER_PW }} + - + name: Build and push + run: | + VERSION=${{ steps.vars.outputs.tag }} + BINLOCATION=$(stack path --local-install-root) + BINLOCATION=$(realpath --relative-to=. $BINLOCATION) + docker build -t filefighter/filehandler:$VERSION -t filefighter/filehandler:stable . --build-arg BINLOCATION=$BINLOCATION + docker push filefighter/filehandler:$VERSION + docker push filefighter/filehandler:stable \ No newline at end of file diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 index 0000000..3e2c396 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for Filehandler + +## Unreleased changes diff --git a/Dockerfile b/Dockerfile index d94c63d..8936738 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,33 +1,23 @@ -FROM ubuntu:16.04 +FROM ubuntu:latest -# Get dumb-init to avoid Ctrl-C issues. See: -# http://engineeringblog.yelp.com/2016/01/dumb-init-an-init-for-docker.html -ADD https://github.com/Yelp/dumb-init/releases/download/v1.1.3/dumb-init_1.1.3_amd64 /usr/local/bin/dumb-init -RUN chmod +x /usr/local/bin/dumb-init +ARG BINLOCATION +ENV RESTURL=FileFighterREST +ENV PROFILE=prod -# Set up Haskell Stack, the Haskell build tool. -# Stack is the only dependency we have to run our application. -# Once available, it will grab everything else we need -# (compiler, libraries, etc). -ADD https://get.haskellstack.org/get-stack.sh /usr/local/bin/ -RUN sh /usr/local/bin/get-stack.sh +RUN apt-get update && apt-get upgrade -y # Copy over the source code and make it executable. -COPY FileHandler.hs /usr/local/bin/file-handler -RUN chmod +x /usr/local/bin/file-handler +ADD $BINLOCATION/bin/Filehandler-exe /usr/local/bin/filehandler-exe +RUN chmod +x /usr/local/bin/filehandler-exe -# Create a new user account and directory to run from, and then -# run everything else as that user. -RUN useradd -m www && mkdir -p /workdir && chown www /workdir -USER www - -# We run our application with "sanity" to force it to install all of -# its dependencies during Docker image build time, making the Docker -# image launch much faster. -RUN /usr/local/bin/file-handler sanity +# TODO: because we want to write to a host directory we must run as root, or change the permissions of the directory +# create group and user, then the working dir and add permissions to it +#RUN groupadd -g 999 appuser && useradd -r -u 999 -g appuser appuser && mkdir -p /workdir && chown appuser /workdir +#USER appuser # We're all ready, now just configure our image to run the server on # launch from the correct working directory. -CMD ["/usr/local/bin/dumb-init", "/usr/local/bin/file-handler"] +# using exec solves ctl + c issues +CMD exec /usr/local/bin/filehandler-exe ${RESTURL} $PROFILE WORKDIR /workdir EXPOSE 5000 \ No newline at end of file diff --git a/FileHandler.hs b/FileHandler.hs deleted file mode 100755 index 2988cb7..0000000 --- a/FileHandler.hs +++ /dev/null @@ -1,143 +0,0 @@ -#!/usr/bin/env stack -{- stack - --resolver lts-6.11 - --install-ghc - runghc - --package shakespeare - --package wai-app-static - --package wai-extra - --package warp - -} - --- The code above is used for Haskell Stack's script interpreter --- feature. For more information, see: --- https://docs.haskellstack.org/en/stable/GUIDE/#script-interpreter --- --- Note how we explicitly list an LTS Haskell snapshot --- (https://www.stackage.org/lts-6.11) to ensure reproducibility. We --- then state which packages need to be present to run this code. - --- Enable the OverloadedStrings extension, a commonly used feature. -{-# LANGUAGE OverloadedStrings #-} - --- We use the QuasiQuotes to embed Hamlet HTML templates inside --- our source file. -{-# LANGUAGE QuasiQuotes #-} - --- Import the various modules that we'll use in our code. -import qualified Data.ByteString.Char8 as S8 -import qualified Data.ByteString.Lazy as L -import Data.Functor.Identity -import Network.HTTP.Types -import Network.Wai -import Network.Wai.Application.Static -import Network.Wai.Handler.Warp -import Network.Wai.Parse -import System.Environment -import System.FilePath -import Text.Blaze.Html.Renderer.Utf8 -import Text.Hamlet - --- | Entrypoint to our application -main :: IO () -main = do - -- For ease of setup, we want to have a "sanity" command line - -- argument. We'll see how this is used in the Dockerfile - -- later. Desired behavior: - -- - -- * If we have the argument "sanity", immediately exit - -- * If we have no arguments, run the server - -- * Otherwise, error out - args <- getArgs - case args of - ["sanity"] -> putStrLn "Sanity check passed, ready to roll!" - [] -> do - putStrLn "Launching DataHandler." - -- 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 - -- "/": send the HTML homepage contents - [] -> send $ responseBuilder - status200 - [("Content-Type", "text/html; charset=utf-8")] - (renderHtmlBuilder homepage) - - -- "/browse/...": use the file server to allow directory - -- listings and downloading files - ("browse":rest) -> - -- We create a modified request that strips off the - -- "browse" component of the path, so that the file server - -- does not need to look inside a /browse/ directory - let req' = req { pathInfo = rest } - in fileServer req' send - - -- "/upload": handle a file upload - ["upload"] -> upload req send - - -- anything else: 404 - _ -> send $ responseLBS - status404 - [("Content-Type", "text/plain; charset=utf-8")] - "Not found" - --- | Create an HTML page which links to the /browse URL, and allows --- for a file upload -homepage :: Html -homepage = [shamlet| -$doctype 5 - - - File server - <body> - <h1>File server - <p> - <a href=/browse/>Browse available files - - <form method=POST action=/upload enctype=multipart/form-data> - <p>Upload a new file - <input type=file name=file> - <input type=submit> -|] - --- | Use the standard file server settings to serve files from the --- current directory -fileServer :: Application -fileServer = staticApp (defaultFileServerSettings ".") - --- | Handle file uploads, storing the file in the current directory -upload :: Application -upload req send = do - -- Parse the request body. We'll ignore parameters and just look - -- at the files - (_params, files) <- parseRequestBody lbsBackEnd req - - -- Look for the file parameter called "file" - case lookup "file" files of - -- Not found, so return a 400 response - Nothing -> send $ responseLBS - status400 - [("Content-Type", "text/plain; charset=utf-8")] - "No file parameter found" - -- Got it! - Just file -> do - let - -- Determine the name of the file to write out - name = takeFileName $ S8.unpack $ fileName file - -- and grab the content - content = fileContent file - -- Write it out - L.writeFile name content - - -- Send a 303 response to redirect back to the homepage - send $ responseLBS - status303 - [ ("Content-Type", "text/plain: charset=utf-8") - , ("Location", "/") - ] - "Upload successful!" diff --git a/Filehandler.cabal b/Filehandler.cabal new file mode 100644 index 0000000..5766b0a --- /dev/null +++ b/Filehandler.cabal @@ -0,0 +1,82 @@ +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.1.0.0 +description: Please see the README on GitHub at <https://github.com/githubuser/Filehandler#readme> +homepage: https://github.com/githubuser/Filehandler#readme +bug-reports: https://github.com/githubuser/Filehandler/issues +author: Author name here +maintainer: example@example.com +copyright: 2021 Author name here +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/LICENSE b/LICENSE new file mode 100644 index 0000000..7caa388 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2021 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md index 7244e6a..318e774 100644 --- a/README.md +++ b/README.md @@ -22,376 +22,10 @@ Text below is from the original code base. --- -## File server demo in a single Haskell file +# Getting started -**Sneak peek**: Run `docker run --rm -p 8080:8080 snoyberg/file-server-demo` and open -[http://localhost:8080](http://localhost:8080). +`stack build --file-watch --watch-all --fast` -We've all been there. We need to write some non-trivial piece of -functionality, and end up doing it in bash or perl because that's what -we have on the server we'll be deploying to. Or because it's the -language we can most easily rely on being present at a consistent -version on our coworkers' machines. We'd rather use a different -language and leverage more advanced, non-standard libraries, but we -can't do that reliably. +`filewatcher --restart '**/*.hs' 'stack build --fast && stack exec Filehandler-exe'` -One option is to create static executables or to ship around Docker -images. This is great for many use cases, and we are going to have a -follow-up blog post about using Docker and Alpine Linux to make such -static executables. But there are at least two downsides to this -approach: - -- It's not possible to modify a static executable directly. You need - to have access to the source code and the tool chain used to produce - it. -- The executable is tied to a single operating system; good luck - getting your Linux executable to run on your OS X machine. - -Said another way: there are good reasons why people like to use -scripting languages. This blog post is going to demonstrate doing some -non-trivial work with Haskell, and do so with a fully reproducible and -trivially installed toolchain, supported on multiple operating -systems. - -## Why Haskell? - -Haskell is a functional programming language with high performance, -great safety features, and a large ecosystem of open source libraries -to choose from. Haskell programs are high level enough to be readable -and modifiable by non-experts, making it ideal for these kinds of -shared scripts. If you're new to Haskell, learn more on -[haskell-lang.org](https://haskell-lang.org/). - -## The task - -We're going to put together a simple file server with upload -capability. We're going to assume a non-hostile environment (like a -corporate LAN with no external network access), and therefore not put -in security precautions like upload size limits. We're going to use -the relatively low-level Web Application Interface instead of a web -framework. While it makes the code a bit longer, there's no magic -involved. Common frameworks in Haskell include -[Yesod](http://www.yesodweb.com/) and -[Servant](http://haskell-servant.readthedocs.io/en/stable/). We're -going to host this all with the blazingly fast Warp web server. - -## Get Stack - -[Stack](https://haskellstack.org) is a cross-platform program for -developing Haskell projects. While it has many features, in our case -the most important bit is that it can: - -- Download a complete Haskell toolchain for your OS -- Install Haskell libraries from a - [curated package set](https://www.stackage.org/) -- Run Haskell source files directly as a script (we'll show how below) - -Check out the -[Get Started page on haskell-lang.org](https://haskell-lang.org/get-started) -to get Stack on your system. - -## The code - -You can see -[the full source code on Github](https://github.com/snoyberg/file-server-demo/blob/master/FileServer.hs). Let's -step through the important parts here. - -### Script interpreter - -We start off our file with something that is distinctly _not_ Haskell -code: - -```haskell -#!/usr/bin/env stack -{- stack - --resolver lts-6.11 - --install-ghc - runghc - --package shakespeare - --package wai-app-static - --package wai-extra - --package warp - -} -``` - -With this header, we've made our file executable from the shell. If -you `chmod +x` the source file, you can run `./FileServer.hs`. The -first line is a standard -[shebang](https://en.wikipedia.org/wiki/Shebang_%28Unix%29). After -that, we have a comment that provides Stack with the relevant command -line options. These options tell it to: - -- Use the Haskell Long Term Support (LTS) 6.11 package set. From now - through the rest of time, you'll be running against the same set of - packages, so no worries about your code bitrotting! -- Install GHC, the Glasgow Haskell Compiler. LTS 6.11 indicates what - version of GHC is needed (GHC 7.10.3). Once again: no bitrot - concerns! -- `runghc` says we'd like to run a script with GHC -- The rest of the lines specify which Haskell library packages we - depend on. You can see a full list of available libraries in LTS - 6.11 [on the Stackage server](https://www.stackage.org/lts-6.11) - -For more information on Stack's script interpreter support, see -[the Stack user guide](https://docs.haskellstack.org/en/stable/GUIDE/#script-interpreter). - -### Command line argument parsing - -Very often with these kinds of tools, we need to handle command line -arguments. Haskell has some great libraries for doing this in an -elegant way. For example, see -[the optparse-applicative library tutorial](https://haskell-lang.org/library/optparse-applicative). However, -if you want to go simple, you can also just use the `getArgs` function -to get a list of arguments. We're going to add support for a `sanity` -argument, which will allow us to sanity-check that running our -application works: - -```haskell -main :: IO () -main = do - args <- getArgs - case args of - ["sanity"] -> putStrLn "Sanity check passed, ready to roll!" - [] -> do - putStrLn "Launching application" - -- Run our application (defined below) on port 8080 - run 8080 app - _ -> error $ "Unknown arguments: " ++ show args -``` - -### Routing - -We're going to support three different routes in our application: - -- The `/browse/...` tree should allow you to get a directory listing - of files in the current directory, and view/download individual - files. -- The `/upload` page accepts a file upload and writes the uploaded - content to the current directory. -- The homepage (`/`) should display an HTML page with a link to - `/browse` and provide an HTML upload form targeting `/upload`. - -Thanks to pattern matching in Haskell, getting this to work is very -straightforward: - -```haskell -app :: Application -app req send = - -- Route the request based on the path requested - case pathInfo req of - -- "/": send the HTML homepage contents - [] -> send $ responseBuilder - status200 - [("Content-Type", "text/html; charset=utf-8")] - (runIdentity $ execHtmlT homepage) - - -- "/browse/...": use the file server to allow directory - -- listings and downloading files - ("browse":rest) -> - -- We create a modified request that strips off the - -- "browse" component of the path, so that the file server - -- does not need to look inside a /browse/ directory - let req' = req { pathInfo = rest } - in fileServer req' send - - -- "/upload": handle a file upload - ["upload"] -> upload req send - - -- anything else: 404 - _ -> send $ responseLBS - status404 - [("Content-Type", "text/plain; charset=utf-8")] - "Not found" -``` - -The most complicated bit above is the path modification for the -`/browse` tree, which is something a web framework would handle for us -automatically. Remember: we're doing this low level to avoid extra -concepts, real world code is typically even easier than this! - -### Homepage content - -An area that Haskell really excels at is Domain Specific Languages -(DSLs). We're going to use the -[Hamlet](http://www.yesodweb.com/book/shakespearean-templates) for -HTML templating. There are many other options in the Haskell world -favoring other syntax, such as -[Lucid library](https://www.stackage.org/package/lucid) (which -provides a Haskell-based DSL), plus implementations of -language-agnostic templates, like -[mustache](https://www.stackage.org/package/mustache). - -Here's what our HTML page looks like in Hamlet: - -```haskell -homepage :: Html () -homepage = [shamlet| -$doctype 5 -<html> - <head> - <title>File server - <body> - <h1>File server - <p> - <a href=/browse/>Browse available files - - <form method=POST action=/upload enctype=multipart/form-data> - <p>Upload a new file - <input type=file name=file> - <input type=submit> -|] -``` - -Note that Hamlet - like Haskell itself - uses significant whitespace -and indentation to denote nesting. - -### The rest - -We're not going to cover the rest of the code in the Haskell file. If -you're interested in the details, please read the comments there, and -feel free to ask questions about any ambiguous bits (hopefully the -inline comments give enough clarity on what's going on). - -## Running - -Download the `FileServer.hs` file contents (or copy-paste, or clone -the repo), make sure the file is executable (`chmod +x FileServer.hs`), and then run: - -```shell -$ ./FileServer.hs -``` - -If you're on Windows, you can instead run: - -```batch -> stack FileServer.hs -``` - -That's correct: the same source file will work on POSIX systems and -Windows as well. The only requirement is Stack and GHC support. Again, -to get Stack on your system, please see the -[Get Started page](https://haskell-lang.org/get-started). - -The first time you run this program, it will take a while to -complete. This is because Stack will need to download and install GHC -and necessary libraries to a user-local directory. Once complete, the -results are kept on your system, so subsequent runs will be almost -instantaneous. - -Once running, you can -[view the app on localhost:8080](http://localhost:8080). - -## Dockerizing - -Generally, I wouldn't recommend Dockerizing a source file like this; -it makes more sense to Dockerize a compiled executable. We'll cover -how to do that another time (though sneak preview: Stack has -[built in support for generating Docker images](https://docs.haskellstack.org/en/stable/yaml_configuration/#image)). For -now, let's actually Dockerize the source file itself, complete with -Stack and the GHC toolchain. - -You can -[check out the Dockerfile on Github](https://github.com/snoyberg/file-server-demo/blob/master/Dockerfile). That -file may be slightly different from what I cover here. - -```dockerfile -FROM ubuntu:16.04 -MAINTAINER Michael Snoyman -``` - -Nothing too interesting... - -```dockerfile -ADD https://github.com/Yelp/dumb-init/releases/download/v1.1.3/dumb-init_1.1.3_amd64 /usr/local/bin/dumb-init -RUN chmod +x /usr/local/bin/dumb-init -``` - -While interesting, this isn't Haskell-specific. We're just using an -init process to get proper handling for signals. For more information, -see -[dumb-init's announcement blog post](http://engineeringblog.yelp.com/2016/01/dumb-init-an-init-for-docker.html). - -```dockerfile -ADD https://get.haskellstack.org/get-stack.sh /usr/local/bin/ -RUN sh /usr/local/bin/get-stack.sh -``` - -Stack has a shell script available to automatically install it on -POSIX systems. We just download that script and then run it. This is -all it takes to have a Haskell-ready system set up: we're now ready to -run script interpreter based files like our `FileServer.hs`! - -```dockerfile -COPY FileServer.hs /usr/local/bin/file-server -RUN chmod +x /usr/local/bin/file-server -``` - -We're copying over the source file we wrote and then ensuring it is -executable. Interestingly, we can rename it to not include a `.hs` -file extension. There is plenty of debate in the world around whether -scripts should or should not include an extension indicating their -source language; Haskell is allowing that debate to perpetuate :). - -```dockerfile -RUN useradd -m www && mkdir -p /workdir && chown www /workdir -USER www -``` - -While not strictly necessary, we'd rather not run our executable as -the root user, for security purposes. Let's create a new user, create -a working directory to store files in, and run all subsequent commands -as the new user. - -```dockerfile -RUN /usr/local/bin/file-server sanity -``` - -As I mentioned above, that initial run of the server takes a long -time. We'd like to do the heavy lifting of downloading and installing -during the Docker image build rather than at runtime. To make this -happen, we run our program once with the `sanity` command line -argument, so that it immediately exits after successfully starting up. - -```dockerfile -CMD ["/usr/local/bin/dumb-init", "/usr/local/bin/file-server"] -WORKDIR /workdir -EXPOSE 8080 -``` - -Finally, we use `CMD`, `WORKDIR`, and `EXPOSE` to make it easier to -run. This Docker image is available on Docker Hub, so if you'd like to try -it out without doing a full build on your local machine: - -```shell -docker run --rm -p 8080:8080 snoyberg/file-server-demo -``` - -You should be able to play with the application on -[http://localhost:8080](http://localhost:8080). - -## What's next - -As you can see, getting started with Haskell as a scripting language -is easy. You may be interested in checking out -[the turtle library](https://www.stackage.org/haddock/lts-6.11/turtle-1.2.8/Turtle-Tutorial.html), -which is a Shell scripting DSL written in Haskell. - -If you're ready to get deeper into Haskell, I'd recommend: - -- Check out [haskell-lang.org](https://haskell-lang.org/), which has a - lot of beginner-targeted information, and we're adding more - regularly. -- Check out - [Haskell Programming from First Principles](http://haskellbook.com/), - a book which will get you completely up and running with Haskell -- Join one of the many - [Haskell online communities](https://haskell-lang.org/community) - -FP Complete both supports the open source Haskell ecosystem, as well -as provides commercial support for those seeking it. If you're -interested in learning more about how FP Complete can help you and -your team be more successful in your development and devops work, you -can -[learn about what services we offer](https://www.fpcomplete.com/dev) -or -[contact us for a free consultation](mailto:consulting@fpcomplete.com). +`stack exec Filehandler-exe` diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 index 0000000..7cd0480 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,385 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +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 qualified Data.Text as DataText +import GHC.Generics +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 +import Data.Maybe ( fromMaybe ) + +-- | Entrypoint to our application +main :: IO () +main = do + -- For ease of setup, we want to have a "sanity" command line + -- argument. We'll see how this is used in the Dockerfile + -- later. Desired behavior: + -- + -- If we have the argument "sanity", immediately exit + -- If we have no arguments, run the server + -- Otherwise, error out + 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 dev 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", "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) + liftIO $ logStdOut (show (http (DataText.pack restUrl) /: "api" /: "v1" /: "filesystem" /: DataText.pack fileId /: "upload")) + liftIO $ logStdOut $ S8.unpack (fileContentType file) + liftIO $ logStdOut $ S8.unpack (responseBody r) + return (responseBody r, responseStatusCode r, responseStatusMessage r) + +download :: Application +download req send = do + let headers = requestHeaders req + restUrl <- getRestUrl + logStdOut "download" + (responseBody, responseStatusCode, responseStatusMessage) <- getApi headers restUrl + case responseStatusCode of + 200 -> do + let d = (eitherDecode $ L.fromStrict responseBody) :: (Either String [RestResponseFile]) + case d of + Left err -> + send $ + responseLBS + HttpTypes.status501 + [("Content-Type", "application/json; charset=utf-8")] + (L.fromStrict $ S8.pack err) + Right files -> + case files of + [fileObject] -> do + let fileID = fileSystemId fileObject + path = getPathFromFileId $ show fileID + realName = name fileObject + fileMimeType = fromMaybe "application/octet-stream" (mimeType fileObject) + send $ + responseFile + HttpTypes.status200 + [ ("Content-Disposition", S8.pack ("attachment; filename=\"" ++ realName ++ "\"")), + ("Content-Type", S8.pack fileMimeType) + ] + path + Nothing + xs -> + withSystemTempFile "FileFighterFileHandler.zip" $ + \tmpFileName handle -> + do + let nameOfTheFolder = "NameOfTheFolderToDownload.zip" + let ss = + mapM + ( \file -> do + inZipPath <- mkEntrySelector $ fromMaybe (name file) (path file) + loadEntry Store inZipPath (getPathFromFileId (show $ fileSystemId file)) + ) + xs + createArchive tmpFileName ss + send $ + responseFile + HttpTypes.status200 + [ ("Content-Disposition", S8.pack ("attachment; filename=\"" ++ nameOfTheFolder ++ "\"")), + ("Content-Type", "application/zip") + ] + tmpFileName + Nothing + _ -> + send $ + responseLBS + (HttpTypes.mkStatus responseStatusCode responseStatusMessage) + [("Content-Type", "application/json; charset=utf-8")] + (L.fromStrict responseBody) + +getApi :: [HttpTypes.Header] -> String -> IO (S8.ByteString, Int, S8.ByteString) +getApi allHeaders restUrl = runReq (defaultHttpConfig {httpConfigCheckResponse = httpConfigDontCheckResponse}) $ do + r <- + req + GET -- method + (http (DataText.pack restUrl) /: "v1" /: "filesystem" /: "download") -- safe by construction URL + -- (http (DataText.pack restUrl) /:"v1" /: "filesystem" /: DataText.pack (S8.unpack (getOneHeader allHeaders "X-FF-IDS" )) /: "info") + NoReqBody -- use built-in options or add your own + bsResponse -- specify how to interpret response + (header "X-FF-IDS" (getOneHeader allHeaders "X-FF-IDS") <> header "Authorization" (getOneHeader allHeaders "Authorization") <> port 8080) --PORT !! + -- mempty -- query params, headers, explicit port number, etc. + liftIO $ logStdOut $ S8.unpack (responseBody r) + 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 + liftIO $ logStdOut $ S8.unpack (responseBody r) + liftIO $ logStdOut (show (http (DataText.pack restUrl) /: "api" /: "v1" /: "filesystem" /: DataText.pack fileId /: "delete") ) + return (responseBody r, responseStatusCode r, responseStatusMessage r) + +health :: Application +health req send = do + deploymentType <- getDeploymentType + foldersIO <- fmap (filterM doesDirectoryExist) (listDirectory ".") + folders <- foldersIO + files <- concat <$> mapM listDirectoryRelative folders + actualFilesSize <- sum <$> mapM getFileSize files + + let response = + object + [ "version" .= ("1.0.0" :: 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 + _ -> "" + +-- 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 diff --git a/src/Lib.hs b/src/Lib.hs new file mode 100644 index 0000000..e356dcb --- /dev/null +++ b/src/Lib.hs @@ -0,0 +1,15 @@ +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/stack.yaml b/stack.yaml new file mode 100644 index 0000000..c5ef460 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,83 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# +# The location of a snapshot can be provided as a file or url. Stack assumes +# a snapshot provided as a file might change, whereas a url resource does not. +# +# 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 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# subdirs: +# - 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: +# +# extra-deps: +# - acme-missiles-0.3 +# - 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 + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=2.5" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# 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 new file mode 100644 index 0000000..9d3217f --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,13 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: [] +snapshots: +- completed: + size: 565266 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/5.yaml + sha256: 78e8ebabf11406261abbc95b44f240acf71802630b368888f6d758de7fc3a2f7 + original: + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/17/5.yaml diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 index 0000000..7df5105 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,18 @@ +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