module Airship.Internal.Route where
import Airship.Resource
import Data.Monoid
import Data.Foldable (foldr')
import Data.Text (Text)
import Data.HashMap.Strict (HashMap, insert)
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Control.Monad.Identity
import Control.Monad.Writer (Writer, WriterT (..), execWriter)
import Control.Monad.Writer.Class (MonadWriter)
import Data.String (IsString, fromString)
newtype Route = Route { getRoute :: [BoundOrUnbound] } deriving (Show, Monoid)
data BoundOrUnbound = Bound Text
| Var Text
| RestUnbound deriving (Show)
instance IsString Route where
fromString s = Route [Bound (fromString s)]
runRouter :: RoutingSpec m a -> [(Route, Resource m)]
runRouter routes = execWriter (getRouter routes)
(</>) :: Route -> Route -> Route
(</>) = (<>)
root :: Route
root = Route []
var :: Text -> Route
var t = Route [Var t]
star :: Route
star = Route [RestUnbound]
newtype RoutingSpec m a = RoutingSpec { getRouter :: Writer [(Route, Resource m)] a }
deriving (Functor, Applicative, Monad, MonadWriter [(Route, Resource m)])
route :: [(Route, a)] -> [Text] -> a -> (a, (HashMap Text Text, [Text]))
route routes pInfo resource404 = foldr' (matchRoute pInfo) (resource404, (mempty, mempty)) routes
matchRoute :: [Text] -> (Route, a) -> (a, (HashMap Text Text, [Text])) -> (a, (HashMap Text Text, [Text]))
matchRoute paths (rSpec, resource) (previousMatch, previousMap) =
case matchesRoute paths rSpec of
Nothing -> (previousMatch, previousMap)
Just m -> (resource, m)
matchesRoute :: [Text] -> Route -> Maybe (HashMap Text Text, [Text])
matchesRoute paths spec = matchesRoute' paths (getRoute spec) (mempty, mempty) False where
matchesRoute' [] [] acc _ = Just acc
matchesRoute' (_ph:_ptl) [] _ _ = Nothing
matchesRoute' r (RestUnbound:_) (h, d) _ = Just (h, d ++ r)
matchesRoute' (ph:ptl) (Bound sh:stt) (h, dispatch) True
| ph == sh
= matchesRoute' ptl stt (h, dispatch ++ [ph]) True
matchesRoute' (ph:ptl) (Bound sh:stt) (h, dispatch) False
| ph == sh
= matchesRoute' ptl stt (h, dispatch) False
matchesRoute' (ph:ptl) (Var t:stt) acc _ = matchesRoute' ptl stt (insert t ph (fst acc), snd acc) True
matchesRoute' _ _ _acc _ = Nothing