File upload with servant

Files.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Files where

import Control.Monad.IO.Class
import Control.Monad.Trans.Either
import Control.Monad.Trans.Resource
import Data.ByteString.Lazy (ByteString)
import Network.Wai
import Network.Wai.Handler.Warp (run)
import Network.Wai.Parse
import Servant
import Servant.Server.Internal

-- Backends for file upload: in memory or in /tmp ?

data Mem

data Tmp

class KnownBackend b where
  type Storage b :: *
  
  withBackend :: Proxy b -> (BackEnd (Storage b) -> IO r) -> IO r

instance KnownBackend Mem where
  type Storage Mem = ByteString

  withBackend Proxy f = f lbsBackEnd

instance KnownBackend Tmp where
  type Storage Tmp = FilePath

  withBackend Proxy f = runResourceT . withInternalState $ \s ->
    f (tempFileBackEnd s)

-- * Files combinator, to get all of the uploaded files

data Files b

instance (KnownBackend b, HasServer api) => HasServer (Files b :> api) where
  type ServerT (Files b :> api) m =
    [File (Storage b)] -> ServerT api m

  route Proxy subserver req respond = withBackend pb $ \b -> do
    (_, files) <- parseRequestBody b req
    route (Proxy :: Proxy api) (subserver files) req respond

    where pb = Proxy :: Proxy b

type FilesMem = Files Mem
type FilesTmp = Files Tmp

-- test

type API = "files" :> FilesTmp :> Post '[JSON] ()
      :<|> Raw

api :: Proxy API
api = Proxy

server :: Server API
server = filesHandler :<|> serveDirectory "."

  where filesHandler :: [File FilePath] -> EitherT ServantErr IO ()
        filesHandler = liftIO . mapM_ ppFile

        ppFile :: File FilePath -> IO ()
        ppFile (name, fileinfo) = do
          putStrLn $ "Input name: " ++ show name
          putStrLn $ "File name: " ++ show (fileName fileinfo)
          putStrLn $ "Content type: " ++ show (fileContentType fileinfo)
          putStrLn $ "------- Content --------"
          readFile (fileContent fileinfo) >>= putStrLn
          putStrLn $ "------------------------"

app :: Application
app = serve api server

f :: IO ()
f = run 8083 app

files.html

<form action="/files" method="post" enctype="multipart/form-data">
	Select a file: <input type="file" name="blah" />
	Select another one: <input type="file" name="foo" />
	<hr />
	<input type="submit" value="Upload" />
</form>

output

Input name: "blah"
File name: "README.md"
Content type: "application/octet-stream"
------- Content --------
# servant

[![Build Status](https://secure.travis-ci.org/haskell-servant/servant.svg)](http://travis-ci.org/haskell-servant/servant)
[![Coverage Status](https://coveralls.io/repos/haskell-servant/servant/badge.svg)](https://coveralls.io/r/haskell-servant/servant)

![servant](https://raw.githubusercontent.com/haskell-servant/servant/master/servant.png)

These libraries provides a family of combinators to define webservices and automatically generate the documentation and client-side querying functions for each endpoint.

In order to minimize the dependencies depending on your needs, we provide these features under different packages.

- `servant`, which contains everything you need to *declare* a webservice API.
- `servant-server`, which lets you *implement* an HTTP server with handlers for each endpoint of an API.
- `servant-client`, which lets you derive automatically Haskell functions that let you query each endpoint of a `servant` webservice.
- `servant-docs`, which lets you generate API docs for your webservice.
- `servant-jquery`, which lets you derive Javascript functions (based on jquery) to query your API's endpoints, in the same spirit as `servant-client`.
- `servant-blaze` and `servant-lucid` provide easy HTML rendering of your data as an `HTML` content-type "combinator".

## Tutorial

We have a [tutorial](http://haskell-servant.github.io/tutorial) guide that introduces the core types and features of servant. After this article, you should be able to write your first servant webservices, learning the rest from the haddocks' examples.

------------------------
Input name: "foo"
File name: "files.html"
Content type: "text/html"
------- Content --------
<form action="/files" method="post" enctype="multipart/form-data">
	Select a file: <input type="file" name="blah" />
	Select another one: <input type="file" name="foo" />
	<hr />
	<input type="submit" value="Upload" />
</form>

------------------------