Types for router

Instances.hs

module Instances where

import Control.Monad

import Types

-- For debugging
instance Show Response where
  show result = show (code result) ++ ": " 
             ++ response result

instance Show Id where
  show (Slug  slug)  = "#" ++ slug
  show (Const const) = const

{- 
| The idea is: there is an routing tree, which has nodes and leafs:
    node :: state -> state?
    leaf :: state -> response?

    ("?" means nullability)

    We have two operators:
      node + node -> node,
      node + leaf -> leaf;
    and
      leaf * leaf -> leaf.

    Obviously, each multiplication chain must end with^W^W be a leaf, 
    because only leaf could produce response - the node is a service object
    made to prefixate it and pre-change environ;

    otherwise, you will have an runtime error.
-}
instance Num Router where
  RouterNode granny * RouterNode mother   = RouterNode $ granny >=> mother
  RouterNode mother * RouterLeaf daughter = RouterLeaf $ mother >=> daughter

  RouterLeaf left   + RouterLeaf right    = RouterLeaf $ first_succsessful [left, right]

  abs         _ = error "`abs` has no meaning for the router"
  signum      _ = error "`signum` has no meaning for the router"
  fromInteger _ = error "`fromInteger` has no meaning for the router"

first_succsessful []             = \state -> Nothing
first_succsessful (action: rest) = \state -> msum [action state, first_succsessful rest state]

Methods.hs

module Methods where

import Types
import Instances

resource name = RouterNode $ \state ->
                  case path state of
                    (top: rest) ->
                      if name == top
                        then let new_path = tail (path state)
                                 new_parsed = parsed state ++ [Const name]
                             in  Just $ RoutingState new_path new_parsed
                        else Nothing
                    _ -> Nothing

end point = RouterLeaf $ \state -> 
              if [point] == path state
                then let new_parsed = parsed state ++ [Const point]
                         new_state  = RoutingState [] new_parsed
                     in Just $ Response 200 (dump new_state)
                else Nothing

nothing = RouterLeaf $ \state -> Nothing

route (RouterLeaf router) path = router $ RoutingState path []

dump state = show (parsed state)

identifier = RouterNode $ \state ->
               case path state of
                 (id: rest) -> if all (`elem` ['0'..'9']) id 
                               then 
                                 let new_parsed = parsed state ++ [Slug id]
                                 in  Just $ RoutingState rest new_parsed
                               else Nothing
                 _          -> Nothing

slug = RouterNode $ \state ->
         case path state of
           (id: rest) -> let new_parsed = parsed state ++ [Slug id]
                         in  Just $ RoutingState rest new_parsed
           _          -> Nothing

root = RouterLeaf $ \state -> 
         if path state == []
           then Just $ Response 200 (dump state)
           else Nothing

RoutingStructure.hs

module RoutingStructure where

import Methods

import qualified Data.Map as Map

type Map = Map.Map

structure = space "v1" 
              `contains` entity_with (the "search" `And` the "foo") "users"
                 `Has` entity "projects"
                   `Has` entity "keys"
                     `Has` entity "translations"
               `And` entity "locale"

data TestCase from to = from :=> to

requests = [["v1"]                                               :=> "Just 200: [v1]",
            ["v1", "users"]                                      :=> "Just 200: [v1,users]",
            ["v1", "users", "search"]                            :=> "Just 200: [v1,users,search]",
            ["v1", "users", "do_funny_things"]                   :=> "Nothing",
            ["v1", "users", "5", "projects", "6"]                :=> "Just 200: [v1,users,#5,projects,#6]",
            ["v1", "users", "5", "projects", "6", "keys"]        :=> "Nothing",
            ["v1", "projects"]                                   :=> "Just 200: [v1,projects]",
            ["v1", "projects", "6"]                              :=> "Just 200: [v1,projects,#6]",
            ["v1", "projects", "6", "keys"]                      :=> "Just 200: [v1,projects,#6,keys]",
            ["v1", "projects", "6", "keys", "7"]                 :=> "Just 200: [v1,projects,#6,keys,#7]",
            ["v1", "projects", "6", "keys", "7", "translations"] :=> "Nothing",
            ["v1", "keys"]                                       :=> "Just 200: [v1,keys]",
            ["v1", "keys", "7"]                                  :=> "Just 200: [v1,keys,#7]",
            ["v1", "keys", "7", "translations"]                  :=> "Just 200: [v1,keys,#7,translations]",
            ["v1", "keys", "7", "translations", "7"]             :=> "Just 200: [v1,keys,#7,translations,#7]"
           ]

main = print $ map (\ (from :=> to) -> 
                          (show $ route (build_routes structure) from) == to) 
                   requests
       
data Structure a = Space String (Structure a)
                 | Class String (Structure a) (Structure a)
                 | Root a
                 | Structure a `Has` Structure a
                 | Structure a `And` Structure a
                 | Ability String
                 | Zero
     deriving (Show, Eq)

infixr 7 `Has`
infixr 6 `And`

entity name = Class name Zero Zero
entity_with ability name = Class name Zero ability

the = Ability

space = Space

slash = Root ()

contains = ($)

infix 0 `contains`

build_routes (Space name rest)                = resource name * (root + build_routes rest)
build_routes (Class name rest abilities)      = resource name * (root + build_routes abilities + identifier * (root + end "edit" + end "delete" + build_routes rest))
build_routes (a `Has` b `Has` c)              = build_routes (a `Has` b `And` b `Has` c)
build_routes (Class a rest abilities `Has` b) = build_routes (Class a (rest `And` b) abilities)
build_routes (a `And` b)                      = build_routes a + build_routes b
build_routes (Ability ability)                = end ability
build_routes  Zero                            = nothing
build_routes (Root _)                         = root

Types.hs

module Types where

data RoutingState = RoutingState { path   :: [Element]
                                 , parsed :: [Id]      }

type Element = String

data Id = Slug  { slug  :: String  }
        | Const { table :: String  }

data Response = Response { code     :: Integer
                         , response :: String }
      
data Router = RouterNode (RoutingState -> Maybe RoutingState)
            | RouterLeaf (RoutingState -> Maybe Response)