module Web.Respond.Path where
import Control.Applicative
import Network.Wai
import qualified Data.Text as T
import qualified Data.Sequence as S
import Safe (headMay)
import Data.Maybe (fromMaybe)
import qualified Control.Monad.State.Class as MState
import qualified Control.Monad.State as StateT
import qualified Control.Monad.Trans.Maybe as MaybeT
import Data.HList
import Web.PathPieces
import Network.HTTP.Types.Method
import Web.Respond.Types
import Web.Respond.Monad
import Web.Respond.Response
import Web.Respond.Method
import Web.Respond.HListUtils
newtype PathMatcher a = PathMatcher {
runPathMatcher :: PathConsumer -> Maybe a
}
instance Functor PathMatcher where
fmap f pm = PathMatcher $ fmap f . runPathMatcher pm
instance Applicative PathMatcher where
pure v = PathMatcher $ pure $ pure v
f <*> r = PathMatcher $ (<*>) <$> runPathMatcher f <*> runPathMatcher r
instance Alternative PathMatcher where
empty = PathMatcher $ const Nothing
l <|> r = PathMatcher $ (<|>) <$> runPathMatcher l <*> runPathMatcher r
instance Monad PathMatcher where
return = pure
a >>= f = PathMatcher $ (>>=) <$> runPathMatcher a <*> flip (runPathMatcher . f)
matchPath :: MonadRespond m => PathMatcher (m ResponseReceived) -> m ResponseReceived
matchPath pm = getPath >>= (fromMaybe handleUnmatchedPath . runPathMatcher pm)
matchPathWithMethod :: MonadRespond m => StdMethod -> PathMatcher (m ResponseReceived) -> PathMatcher (m ResponseReceived)
matchPathWithMethod = fmap . matchOnlyMethod
matchPathWithGET :: MonadRespond m => PathMatcher (m ResponseReceived) -> PathMatcher (m ResponseReceived)
matchPathWithGET = matchPathWithMethod GET
newtype PathExtractor l = PathExtractor {
runPathExtractor :: MaybeT.MaybeT (StateT.State PathConsumer) l
} deriving (Functor, Applicative, Monad, Alternative, MState.MonadState PathConsumer, MonadPlus)
asPathExtractor :: Maybe a -> PathExtractor a
asPathExtractor = maybe empty return
type PathExtractor0 = PathExtractor HList0
type PathExtractor1 a = PathExtractor (HList1 a)
pathExtract :: PathExtractor a -> PathConsumer -> (Maybe a, PathConsumer)
pathExtract = StateT.runState . MaybeT.runMaybeT . runPathExtractor
path :: MonadRespond m => PathExtractor (HList l) -> HListElim l (m a) -> PathMatcher (m a)
path extractor f = PathMatcher $ uncurry (useNextPathState f) . pathExtract extractor
useNextPathState :: MonadRespond m => HListElim l (m a) -> Maybe (HList l) -> PathConsumer -> Maybe (m a)
useNextPathState elim maybeExtraction nextPath = (usePath nextPath . hListUncurry elim) <$> maybeExtraction
pathEndOrSlash :: MonadRespond m => m a -> PathMatcher (m a)
pathEndOrSlash = path endOrSlash
pathLastSeg :: MonadRespond m => T.Text -> m a -> PathMatcher (m a)
pathLastSeg s = path (seg s </> endOrSlash)
(</>) :: PathExtractor (HList l) -> PathExtractor (HList r) -> PathExtractor (HList (HAppendList l r))
(</>) = liftA2 hAppendList
pathEnd :: PathExtractor0
pathEnd = MState.get >>= maybe (return HNil) (const empty) . pcGetNext
singleSegExtractor :: (T.Text -> Maybe (HList a)) -> PathExtractor (HList a)
singleSegExtractor extractor = do
res <- MState.get >>= asPathExtractor . (pcGetNext >=> extractor)
MState.modify pcConsumeNext
return res
unitExtractor :: (T.Text -> Maybe ()) -> PathExtractor0
unitExtractor = singleSegExtractor . (fmap (const HNil) .)
predicateExtractor :: (T.Text -> Bool) -> PathExtractor0
predicateExtractor = unitExtractor . (mayWhen () .)
slashEnd :: PathExtractor0
slashEnd = predicateExtractor T.null
endOrSlash :: PathExtractor0
endOrSlash = pathEnd <|> slashEnd
seg :: T.Text -> PathExtractor0
seg = predicateExtractor . (==)
singleItemExtractor :: (T.Text -> Maybe a) -> PathExtractor1 a
singleItemExtractor = singleSegExtractor . (fmap (hEnd . hBuild) .)
value :: PathPiece a => PathExtractor1 a
value = singleItemExtractor fromPathPiece
pathMethod :: MonadRespond m => StdMethod -> PathExtractor (HList l) -> HListElim l (m ResponseReceived) -> PathMatcher (m ResponseReceived)
pathMethod m extractor = matchPathWithMethod m . path extractor
pathGET :: MonadRespond m => PathExtractor (HList l) -> HListElim l (m ResponseReceived) -> PathMatcher (m ResponseReceived)
pathGET = pathMethod GET
mayWhen :: a -> Bool -> Maybe a
mayWhen v True = Just v
mayWhen _ False = Nothing
usePath :: MonadRespond m => PathConsumer -> m a -> m a
usePath = withPath . const
getConsumedPath :: MonadRespond m => m (S.Seq T.Text)
getConsumedPath = _pcConsumed <$> getPath
getUnconsumedPath :: MonadRespond m => m [T.Text]
getUnconsumedPath = _pcUnconsumed <$> getPath
getNextSegment :: MonadRespond m => m (Maybe T.Text)
getNextSegment = headMay <$> getUnconsumedPath
withNextSegmentConsumed :: MonadRespond m => m a -> m a
withNextSegmentConsumed = withPath pcConsumeNext
newtype Natural = Natural Integer deriving (Eq, Show)
instance PathPiece Natural where
toPathPiece (Natural i) = T.pack $ show i
fromPathPiece s = fromPathPiece s >>= \i -> mayWhen (Natural i) (i >= 1)