Scotty Tutorial

Objective

I wanted to make the contents of my $HOME/content folder publicly accessible through an HTTP server written using the Haskell library scotty.

Suppose, for simplicity, that the server is running on localhost:3000.

If a client requests localhost:3000/path, the server should treat it as a request for the file system object at $HOME/content/path.

In case the object is a file, the file should be sent to the client as the response.

Otherwise, the object must be a folder, so an HTML page with clickable links to the folder's immediate contents should be the response.

Using scotty

Creating an IO () Value

The entry point to any Haskell application is its main :: IO () function.

Web.Scotty provides scotty, which is pretty easy to integrate into any main function.

scotty
    :: Port       -- port to be used by the application
    -> ScottyM () {- a value describing the application's behavior,
                  -- more specifically the responses to different kinds of
                  -- requests
                  -}
    -> IO ()

For situations that demand more finer control, the module also provides:

Creating a ScottyM () Value

Web.Scotty has quite a few functions that eventually evaluate to a value with type ScottyM () - get, post, put, delete, patch, options, addRoute, matchAny, and notFound - it's easy to deduce which function corresponds to which HTTP method.

It makes sense for my application to only respond to properly formatted HTTP GET requests for files and folder paths, and to respond to all other requests with an error message.

I believe get and notFound will satisfy my needs.

get
    :: RoutePattern {- a description of the kind of GET requests that will
                    -- be accepted, either as a fixed string with optional
                    -- parameters, or a regular expression
                    -}
    -> ActionM ()   -- how to construct a reponse to an accepted GET request
    -> ScottyM ()

notFound
    :: ActionM ()   -- the response to an unsupported request
    -> ScottyM ()

Describing a RoutePattern

Web.Scotty provides a handful of functions to create a RoutePattern value, each applicable to a case of a specific complexity.

regex seems to be the most appropriate to my objective because I know valid requests will be shaped like file paths. In other words they will be sequences of letters, numbers, hyphens, and periods, with "/" acting as a path separator. I will not be using characters other than these in my file or folder names.

regex
    :: String {- An extended regular expression.
              -- Only requests matching it are responded to.
              -- Any ActionM () value that uses this
              -- RoutePattern can access the parameter named "0" to get the
              -- whole request, and can access the parameter named "1"
              -- to extract the portion that matches the wildcard characters
              -- in the regex.
              -}
    -> RoutePattern

Synthesizing an ActionM () Value

As is usual for scotty, Web.Scotty has a bunch of functions that yield an ActionM a value. I feel that the ones below will be enough for me.

param will let me find out which file the client wants.

param
    :: Parsable a
    => Text       {- the name of the parameter whose value needs to be
                  -- fetched
                  -}
    -> ActionM a

If the client requests a directory path, I need to prepare an HTML-formatted index of its contents and send it across.

html
    :: Text       {- some HTML to send over to the client -}
    -> ActionM ()

Otherwise, if the client requests a file, I need to send that across as well.

file
    :: FilePath   {- the path of the file on the disk
                  -- to be delivered to a client as a reponse
                  -}
    -> ActionM ()

I want to respond with the text "Server Error" or something similar when the "default" action raises an exception.

rescue
    :: ActionM a           {- a risky operation i.e. one that can throw an
                           -- exception
                           -}
    -> (Text -> ActionM a) {- this eats the message relayed by a thrown
                           -- exception and takes an alternate course of
                           -- action
                           -}
    -> ActionM a

If the client requests a directory path, I need to read the directory's contents to prepare the HTML-formatted index mentioned before. IO actions need to be performed in the IO monad.

liftAndCatchIO
    :: IO a      {- an IO action to perform -}
    -> ActionM a

Filling the IO a Hole

liftAndCatchIO discussed above allows IO actions to be performed in the ActionM monad.

I want to do three different IO actions when the application receives a request for a particular path.

  1. Make sure that the path, with $HOME/content/ prepended to it, represents an existing system location.
  2. If it does, check if the location corresponds to a file or a folder - doesFileExist and doesDirectoryExist.
  3. In case the location is a folder, prepare an HTML-style index of the folder's contents using listDirectory.

Example

Here's a commented version of the server I used to host this website on Amazon Lightsail two years ago.

-- Main.hs

{-# LANGUAGE OverloadedStrings #-}

module Main where

import Data.List (sort, isPrefixOf, isSuffixOf)
import Data.Text.Lazy (Text, append, pack)
import Regex
import System.Directory
import System.FilePath
import Web.Scotty

main :: IO ()
main = scotty
    -- the server needs to listen on port 80 for incoming HTTP requests
    80 $ do

    -- if the request is a GET request matching the extended regular
    -- expression in `path`, run the action defined by `sendFileOrIndexOrError`
    get (regex' path) sendFileOrIndexOrError
    
    -- if the request doesn't match the criterion above, run the action defined
    -- by `decline`
    notFound decline

regex'
    :: Regex        -- a value representing an extended regular expression
    -> RoutePattern -- a `RoutePattern` value to use with scotty's `get`
regex' =
    -- `unRegex` takes the regular expression `String` out of its `newtype`
    -- wrapper while `regex` transforms it into a `RoutePattern`
    regex . unRegex 

path :: Regex
path =
    -- beginning of line
    bol
    
    -- `segment` here is a file or directory name preceded by a forward slash
    -- I expect file and directory names to have only alphabets, numbers,
    -- periods and hyphens, no underscores allowed
    >>> atLeastOne segment

    -- end of line
    >>> eol
  where
    segment = group (char '/' >>> many nameChar)
    nameChar = oneOf [alnum, char '.', char '-']

decline :: ActionM ()
decline = text "I don't accept requests of this form. Sorry."

sendFileOrIndexOrError :: ActionM ()
sendFileOrIndexOrError =
    -- try to run `sendFileOrIndex` but if an exception is raised don't crash,
    -- run `sendError` instead
    rescue sendFileOrIndex sendError
  where
    sendError errMsg = text ("Server Error: " `append` errMsg)

sendFileOrIndex :: ActionM ()
sendFileOrIndex = do
    -- the part of the request body that matches the regular expression is
    -- treated as the path of a file or folder relative to the $HOME/content
    -- directory, except that the first character of `relPath` is always a
    -- forward slash
    relPath <- param "0"
  
    -- the absolute path to $HOME
    home    <- liftAndCatchIO getHomeDirectory

    -- the absolute version of `relPath`
    let absPath = home ++ "/content" ++ relPath

    -- does the item at absPath even exist and is it a file?
    isFile <- liftAndCatchIO (doesFileExist      absPath)

    -- does the item at absPath even exist and is it a directory?
    isDir  <- liftAndCatchIO (doesDirectoryExist absPath)

    case (isFile, isDir) of
        -- if `absPath` is a file then look at the extension of the file and
        -- set the MIME type of the response if possible, then send the content
        -- of the file as the response
        (True, _) -> do
            case (extnToMime . snd . splitExtension) absPath of
                Just mime -> setHeader "Content-Type" mime 
                Nothing   -> return ()
            file absPath

        -- if `absPath` is a folder then generate an index page with the
        -- folder's contents and send that as the response
        (_, True) -> createIndex (relPath, absPath) >>= html

        -- if `absPath` is BOTH file and folder or NEITHER, something must be
        -- wrong
        _         -> decline

extnToMime :: String -> Maybe Text
extnToMime extn = case extn of
    ".html" -> Just "text/html; charset=utf-8"
    ".css"  -> Just "text/css"
    ".js"   -> Just "application/javascript"
    ".txt"  -> Just "text/plain; charset=utf-8"
    ".md"   -> Just "text/plain; charset=utf-8"
    ".svg"  -> Just "image/svg+xml"
    ".png"  -> Just "image/png"
    ".jpeg" -> Just "image/jpeg"
    ".tiff" -> Just "image/tiff"
    ".pdf"  -> Just "application/pdf"
    _       -> Nothing

createIndex
    :: ( FilePath   -- path of a folder relative to $HOME/content
       , FilePath   -- absolute path of the same folder
       )
    -> ActionM Text
createIndex (relPath, absPath) = do
    -- the immediate contents of the directory `absPath` not including `.` and
    -- `..`
    items <- liftAndCatchIO (listDirectory absPath)

    -- make an HTML unordered list with links to the directory's contents as
    -- the list items
    let body' = (unorderedList . map createLink . sort) items

    -- wrap `body'` in a `<body>` element and wrap that in turn in an `<html>`
    -- element that has a `<title>`.
    return (pack (htmlWithTitleAndBody "Contents" body'))
  where
    createLink item = anchorWithHrefAndName
        (homeUrl ++ ensureFwdSlashDelimited relPath ++ item)
        item
        
    -- returns `s` after making sure it begins and ends with a forward slash
    -- because we're going to add `homeUrl` before the opening slash and the
    -- name of a file or folder after the closing slash
    ensureFwdSlashDelimited s =
        (if "/" `isPrefixOf` s then "" else "/") ++
        s                                        ++
        (if "/" `isSuffixOf` s then "" else "/")


homeUrl :: String
homeUrl = "http://www.fyrbll.me"

htmlWithTitleAndBody :: String -> String -> String
htmlWithTitleAndBody title body' = unlines
    [ "<html>"
    , "  <head>"
    , "    <title>" ++ title ++ "</title>"
    , "  </head>"
    , "  <body>" ++ body' ++ "</body>"
    , "</html>"
    ]

anchorWithHrefAndName :: String -> String -> String
anchorWithHrefAndName href name =
    "<a href=" ++ href ++ ">" ++ name ++ "</a>"

unorderedList :: [String] -> String
unorderedList items = "<ul>" ++ (concatMap listItem items) ++ "</ul>"
  where
    listItem item = "<li>" ++ item ++ "</li>"

Here's the Regex module from the file above.

-- Regex.hs

module Regex where

import Data.List (foldl')

metacharacters = "()[].*?+|\\^$"

newtype Regex = Regex { unRegex :: String }

r >>> s = Regex (unRegex r ++ unRegex s)

empty = Regex ""

oneOf rs = Regex ("[" ++ unRegex (foldl' (>>>) empty rs) ++ "]")

group r = Regex ("(" ++ unRegex r ++ ")")

many r = Regex (unRegex r ++ "*")

atLeastOne r = Regex (unRegex r ++ "+")

any = Regex "."

char c = Regex (if c `elem` metacharacters
    then ['\\', c]
    else [c])

bol = Regex "^"

eol = Regex "$"

alnum = Regex "[:alnum:]"

atMostOne r = Regex (unRegex r ++ "?")

Its makefile.

server: Main.hs Regex.hs
    ghc Main.hs -o server -package directory -package filepath \
    -package scotty -package text
    rm Main.hi Main.o Regex.hi Regex.o

To start it once it's compiled.

sudo ./server &

To stop it (assuming no other processes with the name "server").

sudo pkill server