├── .gitignore ├── .travis.yml ├── Dockerfile ├── FileServer.hs ├── LICENSE └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | *~ -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # Use new container infrastructure to enable caching 2 | sudo: false 3 | 4 | # Choose a lightweight base image; we provide our own build tools. 5 | language: c 6 | 7 | # Caching so the next build will be fast too. 8 | cache: 9 | directories: 10 | - $HOME/.ghc 11 | - $HOME/.cabal 12 | - $HOME/.stack 13 | 14 | matrix: 15 | include: 16 | - compiler: ": #Linux" 17 | addons: {apt: {packages: [libgmp,libgmp-dev]}} 18 | - compiler: ": #OS X" 19 | os: osx 20 | 21 | before_install: 22 | # Using compiler above sets CC to an invalid value, so unset it 23 | - unset CC 24 | 25 | # Get the stack executable on the PATH 26 | - mkdir -p ~/.local/bin 27 | - export PATH=$HOME/.local/bin:$PATH 28 | - | 29 | if [ `uname` = "Darwin" ] 30 | then 31 | travis_retry curl --insecure -L https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin 32 | else 33 | travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 34 | fi 35 | 36 | # Make sure we can run our program 37 | script: 38 | - ./FileServer.hs sanity 39 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM ubuntu:16.04 2 | MAINTAINER Michael Snoyman 3 | 4 | # Get dumb-init to avoid Ctrl-C issues. See: 5 | # http://engineeringblog.yelp.com/2016/01/dumb-init-an-init-for-docker.html 6 | ADD https://github.com/Yelp/dumb-init/releases/download/v1.1.3/dumb-init_1.1.3_amd64 /usr/local/bin/dumb-init 7 | RUN chmod +x /usr/local/bin/dumb-init 8 | 9 | # Set up Haskell Stack, the Haskell build tool. 10 | # Stack is the only dependency we have to run our application. 11 | # Once available, it will grab everything else we need 12 | # (compiler, libraries, etc). 13 | ADD https://get.haskellstack.org/get-stack.sh /usr/local/bin/ 14 | RUN sh /usr/local/bin/get-stack.sh 15 | 16 | # Copy over the source code and make it executable. 17 | COPY FileServer.hs /usr/local/bin/file-server 18 | RUN chmod +x /usr/local/bin/file-server 19 | 20 | # Create a new user account and directory to run from, and then 21 | # run everything else as that user. 22 | RUN useradd -m www && mkdir -p /workdir && chown www /workdir 23 | USER www 24 | 25 | # We run our application with "sanity" to force it to install all of 26 | # its dependencies during Docker image build time, making the Docker 27 | # image launch much faster. 28 | RUN /usr/local/bin/file-server sanity 29 | 30 | # We're all ready, now just configure our image to run the server on 31 | # launch from the correct working directory. 32 | CMD ["/usr/local/bin/dumb-init", "/usr/local/bin/file-server"] 33 | WORKDIR /workdir 34 | EXPOSE 8080 -------------------------------------------------------------------------------- /FileServer.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env stack 2 | {- stack 3 | --resolver lts-6.11 4 | --install-ghc 5 | runghc 6 | --package shakespeare 7 | --package wai-app-static 8 | --package wai-extra 9 | --package warp 10 | -} 11 | 12 | -- The code above is used for Haskell Stack's script interpreter 13 | -- feature. For more information, see: 14 | -- https://docs.haskellstack.org/en/stable/GUIDE/#script-interpreter 15 | -- 16 | -- Note how we explicitly list an LTS Haskell snapshot 17 | -- (https://www.stackage.org/lts-6.11) to ensure reproducibility. We 18 | -- then state which packages need to be present to run this code. 19 | 20 | -- Enable the OverloadedStrings extension, a commonly used feature. 21 | {-# LANGUAGE OverloadedStrings #-} 22 | 23 | -- We use the QuasiQuotes to embed Hamlet HTML templates inside 24 | -- our source file. 25 | {-# LANGUAGE QuasiQuotes #-} 26 | 27 | -- Import the various modules that we'll use in our code. 28 | import qualified Data.ByteString.Char8 as S8 29 | import qualified Data.ByteString.Lazy as L 30 | import Data.Functor.Identity 31 | import Network.HTTP.Types 32 | import Network.Wai 33 | import Network.Wai.Application.Static 34 | import Network.Wai.Handler.Warp 35 | import Network.Wai.Parse 36 | import System.Environment 37 | import System.FilePath 38 | import Text.Blaze.Html.Renderer.Utf8 39 | import Text.Hamlet 40 | 41 | -- | Entrypoint to our application 42 | main :: IO () 43 | main = do 44 | -- For ease of setup, we want to have a "sanity" command line 45 | -- argument. We'll see how this is used in the Dockerfile 46 | -- later. Desired behavior: 47 | -- 48 | -- * If we have the argument "sanity", immediately exit 49 | -- * If we have no arguments, run the server 50 | -- * Otherwise, error out 51 | args <- getArgs 52 | case args of 53 | ["sanity"] -> putStrLn "Sanity check passed, ready to roll!" 54 | [] -> do 55 | putStrLn "Launching application" 56 | -- Run our application (defined below) on port 8080 57 | run 8080 app 58 | _ -> error $ "Unknown arguments: " ++ show args 59 | 60 | -- | Our main application 61 | app :: Application 62 | app req send = 63 | -- Route the request based on the path requested 64 | case pathInfo req of 65 | -- "/": send the HTML homepage contents 66 | [] -> send $ responseBuilder 67 | status200 68 | [("Content-Type", "text/html; charset=utf-8")] 69 | (renderHtmlBuilder homepage) 70 | 71 | -- "/browse/...": use the file server to allow directory 72 | -- listings and downloading files 73 | ("browse":rest) -> 74 | -- We create a modified request that strips off the 75 | -- "browse" component of the path, so that the file server 76 | -- does not need to look inside a /browse/ directory 77 | let req' = req { pathInfo = rest } 78 | in fileServer req' send 79 | 80 | -- "/upload": handle a file upload 81 | ["upload"] -> upload req send 82 | 83 | -- anything else: 404 84 | _ -> send $ responseLBS 85 | status404 86 | [("Content-Type", "text/plain; charset=utf-8")] 87 | "Not found" 88 | 89 | -- | Create an HTML page which links to the /browse URL, and allows 90 | -- for a file upload 91 | homepage :: Html 92 | homepage = [shamlet| 93 | $doctype 5 94 | 95 |
96 |