Basic.hs

{-# LANGUAGE
    OverloadedStrings
  , ScopedTypeVariables
  , FlexibleContexts
  , DeriveGeneric
  #-}


module Web.Routes.NestedSpec.Basic where

import Web.Routes.Nested (o_, p_, l_, r_, (</>), match, matchHere, matchGroup, auth, AuthScope (..), textOnly, routeAuth)
import Network.Wai.Trans (Middleware, Application, Request, catchMiddlewareT)
import Network.HTTP.Types (status401, status404, status200)
import Text.Regex (mkRegex)
import Data.Attoparsec.Text (double)
import Control.Monad.Catch (Exception, MonadThrow (throwM))
import GHC.Generics (Generic)


data AuthRole = AuthRole deriving (Show, Eq)
data AuthErr = NeedsAuth deriving (Show, Eq, Generic)

instance Exception AuthErr

-- | If you fail here and throw an AuthErr, then the user was not authorized to
--   under the conditions set by @ss :: [AuthRole]@, and based on the authentication
--   of that user's session from the @Request@ object. Note that we could have a
--   shared cache of authenticated sessions, by adding more constraints on @m@ like
--   @MonadIO@.
--   For instance, even if there are [] auth roles, we could still include a header/timestamp
--   pair to uniquely identify the guest. Or, we could equally change @Checksum ~ Maybe Token@,
--   so a guest just returns Nothing, and we could handle the case in @putAuth@ to
--   not do anything.
authorize :: ( MonadThrow m
             ) => Request -> [AuthRole] -> m ()
-- authorize _ _ = return id -- uncomment to force constant authorization
authorize req ss | null ss   = return ()
                 | otherwise = throwM NeedsAuth

defApp :: Application
defApp _ respond = respond $
  textOnly "404 :(" status404 []

successMiddleware :: Middleware
successMiddleware _ _ respond = respond $ textOnly "200!" status200 []

app :: Application
app =
  let yoDawgIHeardYouLikeYoDawgsYo =
        (routeAuth authorize routes) `catchMiddlewareT` unauthHandle
      routes = do
        matchHere successMiddleware
        matchGroup fooRoute $ do
          matchHere successMiddleware
          auth AuthRole DontProtectHere
          match barRoute    successMiddleware
        match doubleRoute (\_ -> successMiddleware)
        match emailRoute (\_ -> successMiddleware)
        match bazRoute successMiddleware
  in yoDawgIHeardYouLikeYoDawgsYo defApp
  where
    -- `/foo`
    fooRoute = l_ "foo" </> o_

    -- `/foo/bar`
    barRoute = l_ "bar" </> o_

    -- `/foo/1234e12`, uses attoparsec
    doubleRoute = p_ "double" double </> o_

    -- `/athan@foo.com`
    emailRoute = r_ "email" (mkRegex "(^[-a-zA-Z0-9_.]+@[-a-zA-Z0-9]+\\.[-a-zA-Z0-9.]+$)") </> o_

    -- `/baz`, uses regex-compat
    bazRoute = l_ "baz" </> o_

unauthHandle :: AuthErr -> Middleware
unauthHandle NeedsAuth _ _ respond = respond $
  textOnly "Unauthorized!" status401 []