apiary 0.4.0.2 → 0.4.2.0

raw patch · 13 files changed

+264/−143 lines, 13 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• apiary.cabal +16/−6
• src/Control/Monad/Apiary.hs +1/−5
• src/Control/Monad/Apiary/Action.hs +1/−1
• src/Control/Monad/Apiary/Action/Internal.hs +7/−3
• src/Control/Monad/Apiary/Filter.hs +3/−1
• src/Control/Monad/Apiary/Filter/Capture.hs +63/−0
• src/Control/Monad/Apiary/Internal.hs +28/−28
• src/Data/Apiary/Param.hs +43/−0
• src/Data/Apiary/SList.hs +54/−0
• src/Web/Apiary.hs +8/−0
• src/Web/Apiary/TH.hs +1/−2
• src/Web/Apiary/TH/Capture.hs +0/−97
• src/Web/Apiary/TH/Internal.hs +39/−0

@@ -1,5 +1,5 @@ name:                apiary-version:             0.4.0.2+version:             0.4.2.0 x-revision:          1 synopsis:            Simple web framework inspired by scotty. description:@@ -12,7 +12,6 @@   import Web.Apiary   import Network.Wai.Handler.Warp   import qualified Data.ByteString.Lazy.Char8 as L-  import Control.Monad   .   main :: IO ()   main = run 3000 . runApiary def $ do@@ -44,15 +43,26 @@ library   exposed-modules:     Web.Apiary                        Web.Apiary.TH+                        Control.Monad.Apiary                        Control.Monad.Apiary.Filter+                       Control.Monad.Apiary.Filter.Capture                        Control.Monad.Apiary.Action-  other-modules:       Web.Apiary.TH.Capture++                       Data.Apiary.SList+                       Data.Apiary.Param++  other-modules:       Web.Apiary.TH.Internal                        Control.Monad.Apiary.Internal                        Control.Monad.Apiary.Action.Internal-  other-extensions:    TemplateHaskell-                       FlexibleInstances-                       LambdaCase+  other-extensions:    KindSignatures+                     , DataKinds+                     , TypeOperators+                     , GADTs+                     , TypeFamilies++                     , Rank2Types+                          build-depends:       base              >=4.7 && <4.8                      , template-haskell  >=2.9 && <2.10                      , transformers      >=0.3 && <0.5

@@ -6,11 +6,7 @@     -- * getter     , apiaryConfig     -- * execute action-    , action, action_-    -- * Singletons-    , SList(..)-    , Fn, Snoc-    , sSnoc+    , action, action_, actionWithPreAction     -- * Reexport     , module Control.Monad.Apiary.Filter     ) where

@@ -3,7 +3,7 @@       ActionT     , ApiaryConfig(..)     -- * actions-    , stop+    , stop, stopWith      -- ** getter     , getRequest

@@ -75,7 +75,7 @@ data Action a      = Continue a     | Pass-    | Stop ActionState+    | Stop Response  newtype ActionT m a = ActionT { unActionT :: forall b.      ApiaryConfig@@ -132,7 +132,7 @@ execActionT :: ApiaryConfig -> ActionT IO () -> Application execActionT config m request = runActionT m config request resp >>= \case         Pass           -> notFound config request-        Stop s         -> return $ actionStateToResponse s+        Stop s         -> return s         Continue (_,r) -> return $ actionStateToResponse r   where     resp = ActionState (defaultStatus config) (defaultHeader config) (LBS "")@@ -175,7 +175,11 @@  -- | stop handler and send current state. since 0.3.3.0. stop :: Monad m => ActionT m a-stop = ActionT $ \_ _ s _ -> return $ Stop s+stop = ActionT $ \_ _ s _ -> return $ Stop (actionStateToResponse s)++-- | stop with response. since 0.4.2.0.+stopWith :: Monad m => Response -> ActionT m a+stopWith a = ActionT $ \_ _ _ _ -> return $ Stop a  getRequest :: Monad m => ActionT m Request getRequest = ActionT $ \_ r s c -> c r s

@@ -21,12 +21,14 @@ import qualified Data.ByteString as S import Data.Maybe +import Data.Apiary.SList+ import Control.Monad.Apiary.Action.Internal import Control.Monad.Apiary.Internal  -- | raw and most generic filter function. function :: Monad m => (SList c -> Request -> Maybe (SList c')) -> ApiaryT c' m b -> ApiaryT c m b-function f = focus $ \c -> getRequest >>= \r -> case f c r of+function f = focus $ \r c -> case f c r of     Nothing -> mzero     Just c' -> return c' 

@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Control.Monad.Apiary.Filter.Capture where++import Network.Wai++import Control.Applicative+import qualified Data.Text as T+import Data.Apiary.Param+import Data.Apiary.SList++import Control.Monad.Apiary++data Equal   = Equal T.Text+data Fetch a = Fetch++class CaptureElem a where+  type Next a (xs :: [*]) :: [*]+  captureElem :: a -> T.Text -> SList xs -> Maybe (SList (Next a xs))++instance CaptureElem Equal where+    type Next Equal xs = xs+    captureElem (Equal s) p c | s == p    = Just c+                              | otherwise = Nothing++instance Param a => CaptureElem (Fetch a) where+    type Next (Fetch a) xs = (xs `Snoc` a)+    captureElem (Fetch :: Fetch a) p c = (sSnoc c) <$> (readParam p :: Maybe a)+++type Capture as = All CaptureElem as++type family   CaptureResult (bf :: [*]) (as :: [*]) :: [*]+type instance CaptureResult bf '[] = bf+type instance CaptureResult bf (a ': as) = (CaptureResult (Next a bf) as)++capture' :: Capture as => SList as -> [T.Text] -> SList xs -> Maybe (SList (CaptureResult xs as))+capture' SNil       []     bf = Just bf+capture' (c ::: cs) (p:ps) bf = captureElem c p bf >>= capture' cs ps+capture' SNil _ _ = Nothing+capture' _ [] _   = Nothing++-- | low level (without Template Haskell) capture. since 0.4.2.0+--+-- @+-- myCapture :: SList '[Equal, Fetch Int, Fetch String]+-- myCapture = Equal "path" ::: (Fetch :: Fetch Int) ::: (Fetch :: Fetch String) ::: SNil+--+-- capture myCapture . stdMethod GET . action $ \age name -> do+--     yourAction+-- @+capture :: (Capture as, Monad m) => SList as -> ApiaryT (CaptureResult xs as) m b -> ApiaryT xs m b+capture cap = function $ \bf req -> capture' cap (pathInfo req) bf

@@ -2,6 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ImpredicativeTypes #-} {-# LANGUAGE NoMonomorphismRestriction #-}+ {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE GADTs #-}@@ -12,37 +13,23 @@  import Network.Wai import Control.Applicative+import Control.Monad import Data.Monoid+import Data.Apiary.SList  import Control.Monad.Apiary.Action.Internal  newtype ApiaryT c m a = ApiaryT { unApiaryT :: forall b.     (forall x . m x -> IO x)-    -> ActionT IO (SList c)+    -> (Request -> Maybe (SList c))     -> ApiaryConfig     -> (a -> ActionT IO () -> m b)     -> m b      } -data SList (as :: [*]) where-    SNil  :: SList '[]-    SCons :: a -> SList xs -> SList (a ': xs)--type family Fn (as :: [*]) r-type instance Fn '[] r = r-type instance Fn (x ': xs) r = x -> Fn xs r--type family Snoc (as :: [*]) a :: [*]-type instance Snoc '[] a = '[a]-type instance Snoc (x ': xs) a = x ': Snoc xs a--apply :: Fn xs r -> SList xs -> r-apply v SNil = v-apply f (SCons a as) = apply (f a) as--sSnoc :: SList as -> a -> SList (Snoc as a)-sSnoc SNil         a = SCons a SNil-sSnoc (SCons x xs) a = SCons x $ sSnoc xs a+filterToActionT :: Monad m => (Request -> Maybe (SList a))+                -> ActionT m (SList a)+filterToActionT f = getRequest >>= maybe mzero return . f  instance Functor (ApiaryT c m) where     fmap f m = ApiaryT $ \run grd conf cont ->@@ -65,7 +52,7 @@         in hdr'' `seq` cont b hdr''  runApiaryT :: Monad m => ApiaryConfig -> (forall x. m x -> IO x) -> ApiaryT '[] m a -> Application-runApiaryT conf run m req = run (unApiaryT m run (return SNil) conf (\_ w -> return w)) >>= \a ->+runApiaryT conf run m req = run (unApiaryT m run (\_ -> Just SNil) conf (\_ w -> return w)) >>= \a ->     execActionT conf a req  type Apiary c = ApiaryT c IO@@ -76,7 +63,7 @@ getRunner :: Monad m => ApiaryT c m (ActionT m a -> ActionT IO a) getRunner = ApiaryT $ \run _ _ c -> c (hoistActionT run) mempty -getGuard :: ApiaryT c m (ActionT IO (SList c))+getGuard :: ApiaryT c m (Request -> Maybe (SList c)) getGuard = ApiaryT $ \_ grd _ c -> c grd mempty  apiaryConfig :: ApiaryT c m ApiaryConfig@@ -85,21 +72,34 @@ addRoute :: ActionT IO () -> ApiaryT c m () addRoute r = ApiaryT $ \_ _ _ cont -> cont () r -focus :: Monad m => (SList c -> ActionT m (SList c')) -> ApiaryT c' m b -> ApiaryT c m b+focus :: Monad m => (Request -> SList c -> Maybe (SList c')) -> ApiaryT c' m b -> ApiaryT c m b focus g m = do-    tr <- getRunner     ApiaryT $ \run grd cfg cont ->-        unApiaryT m run (grd >>= tr . g) cfg cont+        unApiaryT m run (\r -> grd r >>= \c -> g r c) cfg cont  action :: Monad m => Fn c (ActionT m ()) -> ApiaryT c m ()-action a = do+action = actionWithPreAction_ (return ())++-- | execute action before main action. since v0.4.2.0+actionWithPreAction :: Monad m => (SList xs -> ActionT IO a)+                    -> Fn xs (ActionT m ()) -> ApiaryT xs m ()+actionWithPreAction pa a = do     tr  <- getRunner     grd <- getGuard-    addRoute $ grd >>= tr . apply a+    addRoute $ filterToActionT grd >>= \c -> (pa c) >> tr (apply a c) ++-- | execute no argument action before main action. since v0.4.2.0+actionWithPreAction_ :: Monad m => ActionT IO a+                     -> Fn c (ActionT m ()) -> ApiaryT c m ()+actionWithPreAction_ pa a = do+    tr  <- getRunner+    grd <- getGuard+    addRoute $ filterToActionT grd >>= \c -> pa >> tr (apply a c)+ {-# DEPRECATED action_ "use action method." #-} action_ :: Monad m => ActionT m () -> ApiaryT c m () action_ a = do     tr <- getRunner     grd <- getGuard-    addRoute $ grd >> tr a+    addRoute $ filterToActionT grd >> tr a

@@ -0,0 +1,43 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}++module Data.Apiary.Param where++import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Text.Read+import Data.Int+import Data.Word++class Param a where+  readParam :: T.Text -> Maybe a++instance Param Char where+    readParam s | T.null s  = Nothing+                | otherwise = Just $ T.head s++instance Param Int     where readParam = readMaybe . T.unpack+instance Param Int8    where readParam = readMaybe . T.unpack+instance Param Int16   where readParam = readMaybe . T.unpack+instance Param Int32   where readParam = readMaybe . T.unpack+instance Param Int64   where readParam = readMaybe . T.unpack+instance Param Integer where readParam = readMaybe . T.unpack++instance Param Word   where readParam = readMaybe . T.unpack+instance Param Word8  where readParam = readMaybe . T.unpack+instance Param Word16 where readParam = readMaybe . T.unpack+instance Param Word32 where readParam = readMaybe . T.unpack+instance Param Word64 where readParam = readMaybe . T.unpack++instance Param Double  where readParam = readMaybe . T.unpack+instance Param Float   where readParam = readMaybe . T.unpack++instance Param T.Text where+    readParam = Just++instance Param TL.Text where+    readParam = Just . TL.fromStrict++instance Param String where+    readParam = Just . T.unpack+

@@ -0,0 +1,54 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Apiary.SList where++import GHC.Exts(Constraint)++data SList (as :: [*]) where+    SNil  :: SList '[]+    (:::) :: a -> SList xs -> SList (a ': xs)++infixr :::++deriving instance All Show as => Show (SList as)++type family Fn (as :: [*]) r+type instance Fn '[] r = r+type instance Fn (x ': xs) r = x -> Fn xs r++type family Snoc (as :: [*]) a :: [*]+type instance Snoc '[] a = '[a]+type instance Snoc (x ': xs) a = x ': Snoc xs a++type family All (c :: * -> Constraint) (as :: [*]) :: Constraint+type instance All c '[] = ()+type instance All c (a ': as) = (c a, All c as)++apply :: Fn xs r -> SList xs -> r+apply v SNil = v+apply f (a ::: as) = apply (f a) as++sSnoc :: SList as -> a -> SList (Snoc as a)+sSnoc SNil       a = a ::: SNil+sSnoc (x ::: xs) a = x ::: sSnoc xs a++type family Rev (l :: [*]) (a :: [*]) :: [*]+type instance Rev '[] a = a+type instance Rev (x ': xs) a = Rev xs (x ': a)++type Reverse (a :: [*]) = Rev a '[]++sReverse :: SList as -> SList (Reverse as)+sReverse l = rev l SNil+  where+    rev :: SList as -> SList bs -> SList (Rev as bs)+    rev SNil a = a+    rev (x:::xs) a = rev xs (x:::a)+

@@ -3,8 +3,16 @@       module Control.Monad.Apiary     , module Control.Monad.Apiary.Action     , module Web.Apiary.TH+    -- | MonadIO+    , module Control.Monad.Trans+    -- | MonadPlus(..), msum, mfilter, guard+    , module Control.Monad     ) where  import Control.Monad.Apiary import Control.Monad.Apiary.Action import Web.Apiary.TH++import Control.Monad.Trans(MonadIO(..))+import Control.Monad (MonadPlus(..), msum, mfilter, guard)+

@@ -1,6 +1,5 @@ module Web.Apiary.TH     ( capture-    , Param(..)     ) where -import Web.Apiary.TH.Capture+import Web.Apiary.TH.Internal

@@ -1,97 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}--module Web.Apiary.TH.Capture where--import Control.Monad-import Network.Wai-import Text.Read-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import Language.Haskell.TH-import Language.Haskell.TH.Quote-import Data.Int-import Data.Word--import Control.Monad.Apiary--preCapture :: [Char] -> [T.Text]-preCapture ('/':s) = T.splitOn "/" $ T.pack s-preCapture s       = T.splitOn "/" $ T.pack s--capture :: QuasiQuoter-capture = QuasiQuoter-    { quoteExp  = capture' . preCapture-    , quotePat  = \_ -> error "No quotePat."-    , quoteType = \_ -> error "No quoteType."-    , quoteDec  = \_ -> error "No quoteDec."-    }--class Param a where-  readParam :: T.Text -> Maybe a--instance Param Char where-    readParam s | T.null s  = Nothing-                | otherwise = Just $ T.head s--instance Param Int     where readParam = readMaybe . T.unpack-instance Param Int8    where readParam = readMaybe . T.unpack-instance Param Int16   where readParam = readMaybe . T.unpack-instance Param Int32   where readParam = readMaybe . T.unpack-instance Param Int64   where readParam = readMaybe . T.unpack-instance Param Integer where readParam = readMaybe . T.unpack--instance Param Word   where readParam = readMaybe . T.unpack-instance Param Word8  where readParam = readMaybe . T.unpack-instance Param Word16 where readParam = readMaybe . T.unpack-instance Param Word32 where readParam = readMaybe . T.unpack-instance Param Word64 where readParam = readMaybe . T.unpack--instance Param Double  where readParam = readMaybe . T.unpack-instance Param Float   where readParam = readMaybe . T.unpack--instance Param T.Text where-    readParam = Just--instance Param TL.Text where-    readParam = Just . TL.fromStrict--instance Param String where-    readParam = Just . T.unpack--integralE :: Integral i => i -> ExpQ-integralE = litE . integerL . fromIntegral--capture' :: [T.Text] -> ExpQ-capture' cap = [| function $ \ $(varP $ mkName "cont") request -> -    $(caseE [|pathInfo request|] -        [ match pat   (guards >>= \g -> body >>= \b -> normalB (doE $ g ++ b)) []-        , match wildP (normalB  [|mzero|]) []-        ]) |]-  where-    varNames = zip cap $ map (('v':) . show) [0 :: Int ..]-    pat      = listP $ map (varP . mkName . snd) varNames-    isType s | T.null s        = False-             | T.head s == ':' = True-             | otherwise       = False-    guards = return $ -        map (\(a,v) -> noBindS [|guard $ $(varE $ mkName v) == $(stringE $ T.unpack a) |]) $-        filter (not . isType . fst) varNames-    body = do-        let ss = map (\(a,v) -> do-                ty <- lookupType a-                -- let ty = mkName . T.unpack $ T.tail a-                bindS (varP . mkName $ v ++ "'")-                    [| (readParam $(varE $ mkName v) :: Maybe $(conT ty) ) |])-                    $ filter (isType . fst) varNames-            rt = foldr (\i b -> varE 'sSnoc `appE` b `appE` i) (varE $ mkName "cont") . reverse .-                map (varE . mkName . (++ "'") . snd) $ filter (isType . fst) varNames-        return $ ss ++ [noBindS [| return $rt |]]-    lookupType n =  lookupTypeName (T.unpack $ T.tail n) >>= \case-        Nothing -> fail $ "capture': type not found: " ++ T.unpack (T.tail n)-        Just ty -> return ty--

@@ -0,0 +1,39 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+module Web.Apiary.TH.Internal where++import Language.Haskell.TH+import Language.Haskell.TH.Quote+import Control.Monad.Apiary.Filter.Capture hiding(capture, capture')+import qualified Control.Monad.Apiary.Filter.Capture as Capture+import Data.Apiary.SList+import qualified Data.Text as T++preCap :: String -> [String]+preCap ""  = []+preCap "/" = []+preCap ('/':p) = splitPath p+preCap p       = splitPath p++splitPath :: String -> [String]+splitPath = map T.unpack . T.splitOn "/" . T.pack++mkCap :: [String] -> ExpQ+mkCap [] = [|SNil|]+mkCap ((':':tyStr):as) = do+    -- ty <- lookupTypeName tyStr >>= maybe (fail "") return+    let ty = mkName tyStr+    [|(Fetch :: Fetch $(conT ty)) ::: $(mkCap as) |]+mkCap (eq:as) = do+    [|(Equal $(stringE eq)) ::: $(mkCap as) |]++applyCapture :: ExpQ -> ExpQ+applyCapture e = [|Capture.capture $e|]++capture :: QuasiQuoter+capture = QuasiQuoter +    { quoteExp = applyCapture . mkCap . preCap+    , quotePat  = \_ -> error "No quotePat."+    , quoteType = \_ -> error "No quoteType."+    , quoteDec  = \_ -> error "No quoteDec."+    }