nested-routes (empty) → 0.0.1
raw patch · 7 files changed
+347/−0 lines, 7 filesdep +QuickCheckdep +aesondep +basesetup-changed
Dependencies added: QuickCheck, aeson, base, containers, hspec, http-types, mtl, pseudo-trie, quickcheck-instances, semigroups, text, transformers, wai, wai-extra
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- nested-routes.cabal +45/−0
- src/Web/Routes/Nested.hs +88/−0
- src/Web/Routes/Nested/FileExtListener.hs +105/−0
- src/Web/Routes/Nested/VerbListener.hs +76/−0
- test/Spec.hs +1/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Athan Clark++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Athan Clark nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ nested-routes.cabal view
@@ -0,0 +1,45 @@+Name: nested-routes+Version: 0.0.1+Author: Athan Clark <athan.clark@gmail.com>+Maintainer: Athan Clark <athan.clark@gmail.com>+License: BSD3+License-File: LICENSE+Synopsis: Like scotty, but nested+-- Description:+Cabal-Version: >= 1.10+Build-Type: Simple++Library+ Default-Language: Haskell2010+ HS-Source-Dirs: src+ GHC-Options: -Wall+ Exposed-Modules: Web.Routes.Nested+ Web.Routes.Nested.VerbListener+ Web.Routes.Nested.FileExtListener+ Build-Depends: base >= 4 && < 5+ , wai+ , wai-extra+ , http-types+ , mtl+ , transformers+ , semigroups+ , containers+ , pseudo-trie+ , text+ , aeson++Test-Suite spec+ Type: exitcode-stdio-1.0+ Default-Language: Haskell2010+ Hs-Source-Dirs: src+ , test+ Ghc-Options: -Wall+ Main-Is: Spec.hs+ Build-Depends: base+ , hspec+ , QuickCheck+ , quickcheck-instances++Source-Repository head+ Type: http+ Location: https://github.com/athanclark/nested-routes
+ src/Web/Routes/Nested.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE OverloadedStrings #-}++module Web.Routes.Nested where++import Web.Routes.Nested.FileExtListener+import Web.Routes.Nested.VerbListener++import Network.HTTP.Types+import Network.Wai+import Network.Wai.Middleware.AddHeaders++import Control.Applicative+import Control.Arrow (second, first, (***))+import Control.Monad.IO.Class+import Control.Monad.Trans+import Control.Monad.Writer+import qualified Data.List.NonEmpty as NE+import Data.Monoid+import Data.Trie.Pseudo+import Data.Trie.Rooted+import qualified Data.Trie.Rooted as R+import Data.Traversable+import qualified Data.Text as T+import qualified Data.Map.Lazy as M++newtype HandlerT m a = HandlerT+ { runHandler :: WriterT (MergeRooted T.Text (Verbs Response)) m a }+ deriving (Functor)++deriving instance Applicative m => Applicative (HandlerT m)+deriving instance Monad m => Monad (HandlerT m)+deriving instance MonadIO m => MonadIO (HandlerT m)+deriving instance MonadTrans HandlerT+++handle :: Monad m =>+ [T.Text]+ -> VerbListenerT Response m ()+ -> HandlerT m ()+handle ts vl = do+ vfrs <- lift $ execWriterT $ runVerbListenerT vl++ HandlerT $ tell $+ case ts of+ [] -> MergeRooted $ Rooted (Just vfrs) []+ _ -> MergeRooted $ Rooted Nothing [Rest (NE.fromList ts) vfrs]++route :: (Functor m, Monad m) =>+ HandlerT m a+ -> Request -> (Response -> m b) -> m b+route h req respond = do+ trie <- unMergeRooted <$> (execWriterT $ runHandler h)+ let mMethod = httpMethodToMSym $ requestMethod req+ mFileext = possibleExts $ T.pack $ getFileExt $+ T.unpack $ last $ pathInfo req++ case (mFileext, mMethod) of+ (Just f, Just m) -> case R.lookup (pathInfo req) trie of+ Just map -> case M.lookup (f,m) $ unVerbs map of+ Just r -> respond r+ Nothing -> respond notFound+ Nothing -> respond notFound+ _ -> respond notFound++ where+ getFileExt :: String -> String+ getFileExt s = case foldr go Nothing s of+ Nothing -> ""+ Just x -> x+ where+ go '.' _ = Just "."+ go x (Just xs) = Just $ xs ++ [x]+ go x Nothing = Nothing++ httpMethodToMSym :: Method -> Maybe Verb+ httpMethodToMSym x | x == methodGet = Just Get+ | x == methodPost = Just Post+ | x == methodPut = Just Put+ | x == methodDelete = Just Delete+ | otherwise = Nothing++ notFound = responseLBS status404 [("Content-Type","text/plain")] "404 :("
+ src/Web/Routes/Nested/FileExtListener.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}++module Web.Routes.Nested.FileExtListener where++import qualified Data.Aeson as A+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Encoding as LT+import Network.HTTP.Types (status200)+import Network.Wai++import Control.Applicative+import Control.Monad.Trans+import Control.Monad.Writer+import Data.Monoid+import Data.Map.Lazy+import Data.Traversable+import Data.Foldable hiding (elem)+++data FileExt = Html+ | Json+ | Text+ deriving (Show, Eq, Ord)++possibleExts :: T.Text -> Maybe FileExt+possibleExts x | x `elem` ["", ".htm", ".html"] = Just Html+ | x `elem` [".json"] = Just Json+ | x `elem` [".txt"] = Just Text+ | otherwise = Nothing++newtype FileExts a = FileExts { unFileExts :: Map FileExt a }+ deriving (Show, Eq, Functor, Traversable)++deriving instance Monoid (FileExts a)+deriving instance Foldable FileExts+++newtype FileExtListenerT r m a =+ FileExtListenerT { runFileExtListenerT :: WriterT (FileExts r) m a }+ deriving (Functor)++deriving instance Applicative m => Applicative (FileExtListenerT r m)+deriving instance Monad m => Monad (FileExtListenerT r m)+deriving instance MonadIO m => MonadIO (FileExtListenerT r m)+deriving instance MonadTrans (FileExtListenerT r)+++json :: (A.ToJSON j, Monad m) =>+ j+ -> FileExtListenerT Response m ()+json i =+ let r = responseLBS status200 [("Content-Type", "application/json")] $+ A.encode i+ in+ FileExtListenerT $ tell $+ FileExts $ singleton Json r++jsonp :: (A.ToJSON j, Monad m) =>+ j+ -> FileExtListenerT Response m ()+jsonp i =+ let r = responseLBS status200 [("Content-Type", "application/javascript")] $+ A.encode i+ in+ FileExtListenerT $ tell $+ FileExts $ singleton Json r++text :: (Monad m) =>+ LT.Text+ -> FileExtListenerT Response m ()+text i =+ let r = responseLBS status200 [("Content-Type", "text/plain")] $+ LT.encodeUtf8 i+ in+ FileExtListenerT $ tell $+ FileExts $ singleton Text r+--+-- blaze :: Html -> Response+-- blaze = HR.renderHtml+--+-- lucid :: Monad m => HtmlT m () -> Response+-- lucid = L.renderTextT++-- json :: ToJSON a => a -> Response+-- json = lazy-bytestring . encode++-- text :: T.Text -> Response+-- text = bytestring . TR.encodeUtf8++-- lazy-text :: LT.Text -> Response+-- lazy-text = lazy-bytestring . LTR.encodeUtf8+--+-- builder :: Builder -> Response+-- builder = responseBuilder+--+-- bytestring :: B.ByteString -> Response+-- bytestring = lazy-bytestring . LB.fromStrict+--+-- lazy-bytestring :: LB.ByteString -> Response+-- lazy-bytestring = responseLBS
+ src/Web/Routes/Nested/VerbListener.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}++module Web.Routes.Nested.VerbListener where++import Web.Routes.Nested.FileExtListener++import Network.Wai++import Control.Applicative hiding (empty)+import Control.Monad.Trans+import Control.Monad.Writer+import Data.Monoid+import Data.Foldable+import Data.Traversable+import Data.Map.Lazy+++data Verb = Get+ | Post+ | Put+ | Delete+ deriving (Show, Eq, Ord)++newtype Verbs a = Verbs { unVerbs :: Map (FileExt, Verb) a }+ deriving (Show, Eq, Functor, Traversable)++deriving instance Monoid (Verbs a)+deriving instance Foldable Verbs+++newtype VerbListenerT r m a =+ VerbListenerT { runVerbListenerT :: WriterT (Verbs r) m a }+ deriving (Functor)++deriving instance Applicative m => Applicative (VerbListenerT r m)+deriving instance Monad m => Monad (VerbListenerT r m)+deriving instance MonadIO m => MonadIO (VerbListenerT r m)+deriving instance MonadTrans (VerbListenerT r)+++get :: (Monad m) =>+ FileExtListenerT Response m a+ -> VerbListenerT Response m ()+get flistener = do+ (fileexts :: FileExts Response) <-+ lift $ execWriterT $ runFileExtListenerT flistener+ let new = foldrWithKey (\k -> insert (k, Get)) empty $ unFileExts fileexts++ VerbListenerT $ tell $ Verbs $ new++-- post :: MonadIO m =>+-- (ByteString -> m ())+-- -> FileExtListener ()+-- -> VerbListener ()+-- post fl =+-- VerbListener $ tell $+-- Verbs [(Post, fl)]+--+-- put :: MonadIO m =>+-- (ByteString -> m ())+-- -> FileExtListener ()+-- -> VerbListener ()+-- put fl =+-- VerbListener $ tell $+-- Verbs [(Put, fl)]++-- delete :: (Monad m) =>+-- FileExtListenerT m ()+-- -> VerbListenerT m ()+-- delete fl =+-- VerbListenerT $ tell $+-- Verbs [(Post, fl)]
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}