Serving Static File over WAI middleware

Question

I am developing a web application in Haskell using Servant. I succeeded to load files on server and move them to my SFTP server. Now I want the user to be able to get the file loaded on SFTP (I need to serve to them static files with servant). To manage CORS problems I used WAI middleware library. This is my code where I introduce middleware to set CORS headers.

newtype Welcome
  = Welcome {
        greeting :: String
    }
  deriving (Generic, Eq, Show)

instance ToJSON Welcome
instance FromJSON Welcome

welcomeMesg :: Welcome
welcomeMesg = Welcome "Mbote Ba'a Mpagi!"

type API =
    -- | test for home page
        "home"  -- 1
      :> Get '[JSON] Welcome 
    :<|> "tenants" 
      :> Capture "tenantid" Text
      :> "informations"
      :> MultipartForm Tmp (MultipartData Tmp)
      :> Post '[JSON] (GenericRestResponse InformationCreated ConstructionError)
    :<|> "tenants" -- 3
      :> Capture "tenantid" Text
      :> "informations"
      :> Capture "informationid" Text
      :> "documents"
      :> Raw 

addOriginsAllowed :: Response -> Response
addOriginsAllowed  = 
  let final = (:) ("Access-Control-Allow-Origin", "*") . 
              (:) ("Access-Control-Allow-Methods", "GET, POST, PUT, OPTION") .
              (:) ("Access-Control-Allow-Headers", "Content-Type, Authorization")
  in mapResponseHeaders  final


addAllOriginsMiddleware :: Application -> Application
addAllOriginsMiddleware baseApp req responseFunc =
    let newResponseFunc :: Response -> IO ResponseReceived
        newResponseFunc = responseFunc . addOriginsAllowed
    in baseApp req newResponseFunc


startApp :: IO ()
startApp = run 9080 $ addAllOriginsMiddleware app

proxy :: Proxy API
proxy = Proxy

optionMidlleware :: Middleware
optionMidlleware = provideOptions proxy


app ::  Application
app =  optionMidlleware  $ serve proxy routes

routes :: Server API
routes =
  return
    welcomeMesg -- 1
  :<|> handleCreateInformation --2
  :<|> handlerGetInformationDocuments -- 3

All is working well if I don't make an endpoint where I ask for Raw to serve static files. The last endpoint generate this error:

• No instance for (servant-foreign-0.16:Servant.Foreign.Internal.GenerateList
                     Servant.API.ContentTypes.NoContent
                     (http-types-0.12.4:Network.HTTP.Types.Method.Method
                      -> servant-foreign-0.16:Servant.Foreign.Internal.Req
                           Servant.API.ContentTypes.NoContent))
    arising from a use of ‘provideOptions’
    (maybe you haven't applied a function to enough arguments?)
• In the expression: provideOptions proxy
  In an equation for ‘optionMidlleware’:
      optionMidlleware = provideOptions proxytypecheck(-Wdeferred-type-errors)
provideOptions :: forall api.
(GenerateList NoContent (Foreign NoContent api),
 HasForeign NoTypes NoContent api) =>
Proxy api -> Middleware
Defined in ‘Network.Wai.Middleware.Servant.Options’ (servant-options-0.1.0.0)

_ :: Proxy API -> Middleware 

And this error occurred at the point where I call provideOptions (function of WAI library for middleware)

I am blocked. What can I do to overcome this error?

I try to return ByteString but i is not an instance of ToJson and FromJson

Answer 1

This error is occurring because a Raw endpoint is just an "escape hatch" to non-Servant request/response processing, and so provideOptions, which is Servant-specific middleware, has no way of correctly handling a Raw endpoint in an API.

In more detail, provideOptions uses endpoint-specific HasForeign instances to query the API for supported methods in order to construct a correct Allow header in responding to an OPTIONS request. It can do this for all the Servant endpoints except Raw, which doesn't have a HasForiegn instance.

It might be possible to get something to work in your specific case, but my guess is that you don't need a Raw endpoint here at all. The examples in the Servant cookbook use a Raw endpoint to serve static files, but only because they want to use an essentially non-Servant handler function (serveDirectoryWebApp) to serve a whole directory. (Yes, serveDirectoryWebApp is defined in the servant-server package, but it's really a non-Servant handler. It doesn't really use the Servant API or any Servant handler facilities. It's just a wrapper around serveDirectoryWith from Network.Wai.Application.Static.)

In your case, it sounds like you're just trying to write a plain Servant handler handlerGetInformationDocuments that is accessing the file directly and collecting its contents in a ByteString, and you want to provide that ByteString as the content returned in response to the client's GET request. If so, instead of a Raw endpoint, you just want a Get endpoint that returns an octet stream, something like:

import qualified Text.ByteString.Lazy as LBS

... :> "documents" :> Get '[OctetStream] LBS.ByteString

and the handler can just return the ByteString:

handlerGetInformationDocuments :: Text -> Text -> Handler LBS.ByteString
handlerGetInformationDocuments tenantid informationid = do
  content <- liftIO $ LBS.readFile "file.bin"
  pure content

Above, I used a lazy ByteString, which is probably best if the files are somewhat large, though you want to take care not to modify a file in place once you've started serving it. Strict ByteStrings would work fine, too, especially if the files are small.

Update:

Unfortunately, as per your follow up comment, this still doesn't work, and you get an error about JSON expected. The problem is that, as mentioned above, provideOptions uses the servant-foreign package, and this package only supports JSON endpoints. This is (barely) documented in a comment in the documentation:

This is a severe limitation of servant-foreign currently, as we only allow the content type to be JSON... Thus, any routes looking like this will work:

"foo" :> Get '[JSON] Foo

while routes like

"foo" :> Get '[MyFancyContentType] Foo

will fail with an error like

* JSON expected in list '[MyFancyContentType]

Unfortunately, I think the most reasonable fix is to toss out servant-options and write your own provideOptions that doesn't depend on servant-foreign. This can be done with a HasMethods class with instances for the API types that enumerate all the methods for a given path:

class HasMethods api where
  getMethods :: Proxy api -> [Text] -> [Method]

instance (HasMethods api1, HasMethods api2) => HasMethods (api1 :<|> api2) where
  getMethods _ path = getMethods @api1 Proxy path ++ getMethods @api2 Proxy path
instance (KnownSymbol seg, HasMethods sub) => HasMethods (seg :> sub) where
  getMethods _ (seg:path) | symbolVal @seg Proxy == Text.unpack seg = getMethods @sub Proxy path
  getMethods _ _ = []
instance (HasMethods sub) => HasMethods (Capture name a :> sub) where
  getMethods _ (_:path) = getMethods @sub Proxy path
  getMethods _ [] = []
instance (HasMethods sub) => HasMethods (CaptureAll name a :> sub) where
  getMethods _ _ = getMethods @sub Proxy []
instance (HasMethods sub) => HasMethods (Header sym x :> sub) where
  getMethods _ = getMethods @sub Proxy
instance (HasMethods sub) => HasMethods (ReqBody sym x :> sub) where
  getMethods _ = getMethods @sub Proxy
instance (HasMethods sub) => HasMethods (QueryParam sym x :> sub) where
  getMethods _ = getMethods @sub Proxy
instance (HasMethods sub) => HasMethods (QueryParams sym x :> sub) where
  getMethods _ = getMethods @sub Proxy
instance (HasMethods sub) => HasMethods (QueryFlag sym x :> sub) where
  getMethods _ = getMethods @sub Proxy
instance (HasMethods sub) => HasMethods (Fragment x :> sub) where
  getMethods _ = getMethods @sub Proxy
instance (HasMethods sub) => HasMethods (MultipartForm tag a :> sub) where
  getMethods _ = getMethods @sub Proxy
instance (ReflectMethod method) => HasMethods (Verb method status ctypes a) where
  getMethods _ [] = [reflectMethod (Proxy @method)]
  getMethods _ _ = []

You can test this out on your API by running things like:

> getMethods @API Proxy ["tenants"]
[]   -- because the path http://host/tenants isn't an endpoint
> getMethods @API Proxy ["tenants", "myTenantId", "informations"]
["POST"]
> getMethods @API Proxy ["home"]
["GET"]

Then, you can write a provideOptions middleware function that constructs the correct Allow header based on the getMethods result for the current request path:

provideOptions :: (HasMethods api) => Proxy api -> Middleware
provideOptions p app req resp
  | requestMethod req == "OPTIONS" = case getMethods p (pathInfo req) of
      [] -> app req resp
      methods -> resp $ responseLBS
        (Status 200 "OK")
        [("Allow", BS.intercalate ", " ("OPTIONS" : nub methods))]
        ""
  | otherwise = app req resp

Anyway, here's a complete runnable example based on your original code showing this new provideOptions implementation at work. It hosts a web form at:

http://localhost:9080/

that lets you POST a file to:

http://localhost:9080/upload

and retrieve files by numeric ID at:

http://localhost:9080/download/1
http://localhost:9080/download/2
etc.

The middleware appears work correctly. For example:

$ telnet localhost 9080
Trying 127.0.0.1...
Connected to localhost.
Escape character is '^]'.
OPTIONS /files/upload HTTP/1.0

HTTP/1.0 200 OK
Date: Thu, 21 Mar 2024 03:39:29 GMT
Server: Warp/3.3.25
Access-Control-Allow-Origin: *
Access-Control-Allow-Methods: GET, POST, PUT, OPTION
Access-Control-Allow-Headers: Content-Type, Authorization
Allow: OPTIONS, POST

Connection closed by foreign host.
$

The full example:

{-# LANGUAGE GHC2021 #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}

import Servant
import Servant.Multipart
import Data.Aeson
import Network.Wai
import Network.Wai.Handler.Warp (run)
import Network.HTTP.Types (Status(..), Method)
import Network.HTTP.Media ((//), (/:))
import Data.List (nub)
import Control.Monad.IO.Class (liftIO)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Builder as Builder
import Data.IORef
import GHC.Generics
import GHC.TypeLits

-- `provideOptions` replacement for servant-options

provideOptions :: (HasMethods api) => Proxy api -> Middleware
provideOptions p app req resp
  | requestMethod req == "OPTIONS" = case getMethods p (pathInfo req) of
      [] -> app req resp
      methods -> resp $ responseLBS
        (Status 200 "OK")
        [("Allow", BS.intercalate ", " ("OPTIONS" : nub methods))]
        ""
  | otherwise = app req resp

class HasMethods api where
  getMethods :: Proxy api -> [Text] -> [Method]
instance (HasMethods api1, HasMethods api2) => HasMethods (api1 :<|> api2) where
  getMethods _ path = getMethods @api1 Proxy path ++ getMethods @api2 Proxy path
instance (KnownSymbol seg, HasMethods sub) => HasMethods (seg :> sub) where
  getMethods _ (seg:path) | symbolVal @seg Proxy == T.unpack seg = getMethods @sub Proxy path
  getMethods _ _ = []
instance (HasMethods sub) => HasMethods (Capture name a :> sub) where
  getMethods _ (_:path) = getMethods @sub Proxy path
  getMethods _ [] = []
instance (HasMethods sub) => HasMethods (CaptureAll name a :> sub) where
  getMethods _ _ = getMethods @sub Proxy []
instance (HasMethods sub) => HasMethods (Header sym x :> sub) where
  getMethods _ = getMethods @sub Proxy
instance (HasMethods sub) => HasMethods (ReqBody sym x :> sub) where
  getMethods _ = getMethods @sub Proxy
instance (HasMethods sub) => HasMethods (QueryParam sym x :> sub) where
  getMethods _ = getMethods @sub Proxy
instance (HasMethods sub) => HasMethods (QueryParams sym x :> sub) where
  getMethods _ = getMethods @sub Proxy
instance (HasMethods sub) => HasMethods (QueryFlag sym :> sub) where
  getMethods _ = getMethods @sub Proxy
instance (HasMethods sub) => HasMethods (Fragment x :> sub) where
  getMethods _ = getMethods @sub Proxy
instance (HasMethods sub) => HasMethods (MultipartForm tag a :> sub) where
  getMethods _ = getMethods @sub Proxy
instance (ReflectMethod method) => HasMethods (Verb method status ctypes a) where
  getMethods _ [] = [reflectMethod (Proxy @method)]
  getMethods _ _ = []

-- HTML support (you can ignore this)

data HTML
instance Accept HTML where
  contentType _ = "text" // "html" /: ("charset", "utf-8")

instance MimeRender HTML Text where
  mimeRender _ = BS.fromStrict . T.encodeUtf8

-- Our API

data UploadResponse = UploadResponse
  { status :: Text, documentId :: Int
  } deriving (Show, Generic)
instance ToJSON UploadResponse

type API = Get '[HTML] Text
           :<|> "upload"
                :> MultipartForm Mem (MultipartData Mem)
                :> Post '[JSON] UploadResponse
           :<|> "download"
                :> Capture "documentId" Int
                :> Get '[OctetStream] LBS.ByteString

addAllOriginsMiddleware :: Application -> Application
addAllOriginsMiddleware baseApp req responseFunc =
    let newResponseFunc :: Response -> IO ResponseReceived
        newResponseFunc = responseFunc . addOriginsAllowed
    in baseApp req newResponseFunc

  where addOriginsAllowed =
          let final =
                (:) ("Access-Control-Allow-Origin", "*") .
                (:) ("Access-Control-Allow-Methods", "GET, POST, PUT, OPTION") .
                (:) ("Access-Control-Allow-Headers", "Content-Type, Authorization")
          in mapResponseHeaders  final

handleOptionsMiddleware :: Middleware
handleOptionsMiddleware = provideOptions (Proxy @API)

app :: IORef Int -> Application
app nextId = addAllOriginsMiddleware $ handleOptionsMiddleware $ serve (Proxy @API) routes
  where

    routes = handleHomepage :<|> handleUpload :<|> handleDownload

    handleHomepage = do
      n <- liftIO $ readIORef nextId
      let downlink i = "<li><a href=/download/" <> i' <> ">file " <> i' <> "</a>"
            where i' = Builder.fromString (show i)
          downlinks | n == 0 = "<li>No files yet</li>"
                    | otherwise = LT.toStrict . Builder.toLazyText $ mconcat (map downlink [1..n])
      pure $ "<!doctype html> \
          \ <h3>Upload</h3><form action=/upload method=post enctype=multipart/form-data> \
          \ <p><input type=file name=file><p><button type=submit>Submit</button></form> \
          \ <h3>Download</h3><ul>" <> downlinks <> "</ul>"

    handleUpload :: MultipartData Mem -> Handler UploadResponse
    handleUpload mpd = case files mpd of
      [file] -> do i <- liftIO $ atomicModifyIORef' nextId (\i -> (i+1,i+1))
                   liftIO $ LBS.writeFile (filename i) (fdPayload file)
                   pure $ UploadResponse "success" i
      _ -> throwError err400

    handleDownload :: Int -> Handler LBS.ByteString
    handleDownload i = liftIO $ LBS.readFile (filename i)

    filename i = "file" ++ show i ++ ".dat"

main :: IO ()
main = do
  nextId <- newIORef 0
  run 9080 (app nextId)