Router mark 2

gistfile1.hs

{-# LANGUAGE RecordWildCards #-}

import Control.Monad

{- 
  Later, `Class {..}` will autobind all attributes to their names
  in the field of visibility
-}
data Structure = Class   { name      :: String 
                         , abilities :: Structure
                         , nested    :: Structure }

               | Ability { name      :: String}
               | Structure `Has` Structure
               | Structure `And` Structure
               | Root
               | Zero 

-- run with expressions like: 
-- route (decomposed structure) POST "/keys/5/translations/"

structure = (entity "user" |> with "search")
            `Has` (entity "project"
               `Has` entity "keys"
                  `Has` (entity "translations" |> with "statistics"))

            `And` entity "friends"
               `Has` (entity "dialogs"
                  `Has` entity "messages"

               `And` entity "relations")

entity name = Class { name      = name 
                    , abilities = Zero
                    , nested    = Zero }

with ability klass@Class {..} = 
    klass { abilities = Ability ability `And` abilities }

x |> f = f x

decomposed Class {..} = 
    plate name /> (method GET  /> action   "index"
               \/  method GET  /> endpoint "new"
               \/  method POST /> action   "create"

               \/  decomposed abilities

               \/  slug /> (method GET    /> action   "show"
                        \/  method GET    /> endpoint "edit"
                        \/  method PUT    /> action   "update"
                        \/  method DELETE /> action   "destroy"

                        \/  decomposed nested))
   
    where action  = const root  -- looks more clear

decomposed (granny `Has` mother `Has` son) = 
            decomposed (granny `Has` mother 
                      `And` 
                      mother `Has` son)  -- autolifting all to 1-level deep nesting

decomposed (mother `Has` son) = decomposed mother { nested = son `And` nested mother }

decomposed (left `And` right) = decomposed left \/ decomposed right

decomposed  Root              = root

decomposed (Ability name)     = methods [GET, POST] /> endpoint name

decomposed  Zero              = nothing

infixl 9   |>
infixr 6 `Has`, />
infixl 5 `And`, \/

newtype End  = End  (Request -> Maybe Request)
newtype Node = Node (Request -> Maybe Request)

data Request = Request { requestMethod ::  Method
                       , path          :: [String]
                       , pieces        :: [Piece]  } deriving Show

data Method = GET 
            | PUT 
            | POST 
            | DELETE deriving (Eq, Show)

data Piece = Slug     String
           | Plate    String
           | Endpoint String deriving Show

Node granny // Node mom = Node (mom <=< granny)
Node mom    /> End  son = End  (son <=< mom)

End left \/ End right = End (left `orelse` right)

orelse left right x = msum [left x, right x] -- first successful action

method m =
    Node $ \request@Request {..} ->

        do guard (requestMethod == m)
           return request

methods ms =
    Node $ \request@Request {..} ->

        do guard (requestMethod `elem` ms)
           return request

plate name =
    Node $ \request@Request {..} ->

        do head <- tryBehead path
           guard (name == head)

           let path'   = tail path
           let pieces' = Plate name : pieces

           return request { path   = path' 
                          , pieces = pieces' }

slug =
    Node $ \request@Request {..} ->
        do head <- tryBehead path
           guard (from ['0'..'9'] `all` head)

           let path'   = tail path
           let pieces' = Slug head : pieces

           return request { path   = path' 
                          , pieces = pieces' }

    where from = flip elem

root =
    End $ \request@Request {..} ->
        do guard (path == []) 
           return request

endpoint name =
    End $ \request@Request {..} ->

        do guard (path == [name])

           let path'   = tail path
           let pieces' = Endpoint name : pieces

           return request { path   = path' 
                          , pieces = pieces' }

nothing = End (const Nothing)

tryBehead []      = Nothing
tryBehead (a : _) = Just a

route (End router) method path = router $ Request method (words $ (replace '/' ' ') path) []

replace a b = map $ \c -> if c == a then b else c