Parse routes

routes-imperative.hs

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

import Control.Arrow((>>>), (&&&))
import Data.Maybe (catMaybes)
import qualified Data.Text as T
import Data.Text (Text)
import Data.List.NonEmpty (NonEmpty, nonEmpty)

data ApiRoute = ApiRoute { method :: Method, path :: Path } deriving Show
data Method = LIST | POST deriving Show
type Path = NonEmpty PathFrag
type PathFrag = Text

parse :: Text -> Maybe ApiRoute
parse = T.words >>> (methodP &&& pathsP)
    >>> \case (Just method, Just path) -> Just ApiRoute{..}
              _                        -> Nothing
  where
    methodP ("LIST":_) = Just LIST
    methodP ("POST":_) = Just POST
    methodP _ = Nothing
    pathsP (_:[paths]) = nonEmpty . dropWhile (== "") . T.split (== '/') $ paths
    pathsP _ = Nothing

routes-parser-combinators.hs

{-# LANGUAGE RecordWildCards #-}

import qualified Text.Parsec as P
import Text.Parsec (Parsec, ParseError, (<|>), runP)
import Data.Functor ((<&>), ($>))

data ApiRoute = ApiRoute { method :: Method, path :: Path } deriving Show
data Method = LIST | POST deriving Show
type Path = [PathFrag]
data PathFrag = Static String | Capture String deriving Show

type ParseResult = Either ParseError ApiRoute

parse :: String -> ParseResult
parse = runP apiRouteP () ""
  where
    apiRouteP = do
      method <- methodP
      _      <- P.spaces
      path   <- pathP
      return $ ApiRoute{..}
      where
        methodP = (P.string "LIST" $> LIST) <|> (P.string "POST" $> POST)
        pathP = P.many1 $ P.char '/' *> pathFragP
          where
            pathFragP = (letters >>= return . Static)
                    <|> (leftCurlyBrace *> letters <* rightCurlyBrace <&> Capture)

        letters = P.many1 P.letter
        leftCurlyBrace = P.char '{'
        rightCurlyBrace = P.char '}'

    rightToMaybe = either (const Nothing) Just

------------
-- Testcases
------------
-- LIST /domains/{domain}/info
-- Just (ApiRoute {method = LIST, path = [Static "domains",Capture "domain",Static "info"]})

-- POST /domains/{domain}/users
-- Just (ApiRoute {method = POST, path = [Static "domains",Capture "domain",Static "users"]})

-- Note: Not all METHODS are currently parsed e.g. GET, PUT ...
--       Not all PATHS are currently parsed e.g. '/'