REST.hs

-- | This module provides data types useful for declaring RESTful routes.
-- 'Resource' is provided for the common case of resource specified
-- by a unique identifier (for e.g. @\/products\/3@). 'SingletonResource'
-- is provided for resources that do not require an identifier. Typical
-- usage would be as follows:
--
-- @
-- data AppUrl
--     = User (Resource Int)
--     | Profile SingletonResource
--     | Login
--     | Logout
-- @
--
-- This now allows you to define handlers for different end points for
-- your resource.
-- @
-- routeAppUrl appUrl =
--     case appUrl of
--       Login          -> with auth handleLogin   -- \/login
--       Logout         -> with auth handleLogout  -- \/logout
--       User Index     -> handleUserIndex         -- \/user
--       User New       -> handleUserNew           -- \/user\/new
--       User (Show n)  -> handleUserShow n        -- \/user\/:Int
--       User (Edit n)  -> handleUserEdit n        -- \/user\/:Int\/edit
--       Profile ShowS  -> handleProfileShow       -- \/profile
--       Profile NewS   -> handleProfileNew        -- \/profile/new
--       Profile EditS  -> handleProfileEdit       -- \/profile/edit
-- @
--

{-# LANGUAGE OverloadedStrings #-}

module Snap.Snaplet.Router.REST
    ( Resource (..)
    , SingletonResource (..)
    ) where


import Control.Applicative
import Web.Routes.PathInfo (PathInfo (..), segment, toPathSegments, fromPathSegments)


-- | A data type to represent RESTful resources that have a unique identifier.
-- The data type used as the identifier must be an instance of 'PathInfo'.
data (PathInfo id) => Resource id
    = Index
    | New
    | Show id
    | Edit id
      deriving (Eq, Show, Read)


-- | A data type to represent singleton RESTful resources. Generally these
-- are identified in some other way, often the user's session.
data SingletonResource
    = ShowS
    | NewS
    | EditS
      deriving (Eq, Show, Read)


instance (PathInfo id) => PathInfo (Resource id) where
    toPathSegments Index = []
    toPathSegments New   = ["new"]
    toPathSegments (Show n) = toPathSegments n
    toPathSegments (Edit n) = toPathSegments n ++ ["edit"]

    fromPathSegments =
            New <$ segment "new"
        <|> fromPathSegments <**> ((pure Edit <* segment "edit") <|> pure Show)
        <|> pure Index


instance PathInfo SingletonResource where
    toPathSegments ShowS = []
    toPathSegments NewS  = ["new"]
    toPathSegments EditS = ["edit"]

    fromPathSegments =
            NewS <$ segment "new"
        <|> EditS <$ segment "edit"
        <|> pure ShowS