exceptions.hs

{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, ScopedTypeVariables #-}
{-# language DeriveAnyClass #-}
{-# language LambdaCase #-}
module Main (main) where

import Control.Exception (Exception(..))
import Control.Monad.IO.Class
import Control.Monad.IO.Unlift (MonadUnliftIO(..))

import Data.String (fromString)
import Data.Typeable

import Network.HTTP.Types
import Network.Wai.Middleware.RequestLogger

import System.Random

import Web.Scotty.Trans

-- | A custom exception type.
data Except = Forbidden | NotFound Int | StringEx String
    deriving (Show, Eq, Typeable, Exception)

-- | User-defined exceptions should have an associated Handler:
handleEx :: MonadIO m => ErrorHandler m
handleEx = Handler $ \case
  Forbidden -> do
    status status403
    html "<h1>Scotty Says No</h1>"
  NotFound i -> do
    status status404
    html $ fromString $ "<h1>Can't find " ++ show i ++ ".</h1>"
  StringEx s -> do
    status status500
    html $ fromString $ "<h1>" ++ s ++ "</h1>"

main :: IO ()
main = do
  scottyT 3000 id server -- note: we use 'id' since we don't have to run any effects at each action

-- Any custom monad stack will need to implement 'MonadUnliftIO'
server :: MonadUnliftIO m => ScottyT m ()
server = do
    middleware logStdoutDev

    defaultHandler handleEx    -- define what to do with uncaught exceptions

    get "/" $ do
        html $ mconcat ["<a href=\"/switch/1\">Option 1 (Not Found)</a>"
                       ,"<br/>"
                       ,"<a href=\"/switch/2\">Option 2 (Forbidden)</a>"
                       ,"<br/>"
                       ,"<a href=\"/random\">Option 3 (Random)</a>"
                       ]

    get "/switch/:val" $ do
        v <- pathParam "val"
        _ <- if even v then throw Forbidden else throw (NotFound v)
        text "this will never be reached"

    get "/random" $ do
        rBool <- liftIO randomIO
        i <- liftIO randomIO
        let catchOne Forbidden = html "<h1>Forbidden was randomly thrown, but we caught it."
            catchOne other     = throw other
        throw (if rBool then Forbidden else NotFound i) `catch` catchOne