restful-snap 0.2 → 0.4.1
raw patch · 4 files changed
+127/−106 lines, 4 filesdep +map-syntaxdep +time-locale-compatdep ~blaze-builderdep ~data-defaultdep ~digestive-functorsnew-uploader
Dependencies added: map-syntax, time-locale-compat
Dependency ranges changed: blaze-builder, data-default, digestive-functors, errors, heist, lens, mtl, readable, snap, snap-core, snap-extras, template-haskell, text, time
Files
- changelog.md +5/−0
- restful-snap.cabal +22/−17
- src/Snap/Restful.hs +74/−75
- src/Snap/Restful/TH.hs +26/−14
+ changelog.md view
@@ -0,0 +1,5 @@+0.4.1+* Bump various dependency upper bounds.++0.4+* Support newer versions of heist
restful-snap.cabal view
@@ -1,5 +1,5 @@ name: restful-snap-version: 0.2+version: 0.4.1 description: A convention-based RESTful routing mechanism for snap license: BSD3 license-file: LICENSE@@ -11,6 +11,9 @@ cabal-version: >=1.8 homepage: https://github.com/ozataman/restful-snap +extra-source-files:+ changelog.md+ source-repository head type: git location: https://github.com/ozataman/restful-snap.git@@ -18,29 +21,31 @@ library hs-source-dirs: src - exposed-modules: + exposed-modules: Snap.Restful Snap.Restful.TH - build-depends: + build-depends: base >= 4 && < 5,- blaze-builder >= 0.3 && < 0.4,+ blaze-builder >= 0.3 && < 0.5, bytestring >= 0.8 && < 0.11, containers >= 0.4 && < 0.6,- data-default >= 0.5 && < 0.6,- digestive-functors >= 0.6 && < 0.7,- heist >= 0.12 && < 0.13,- lens >= 3.8 && < 3.10,- mtl >= 2.0 && < 2.2,+ data-default >= 0.5 && < 0.8,+ digestive-functors >= 0.6 && < 0.9,+ errors >= 2.0 && < 2.3,+ heist >= 0.14 && < 1.1,+ lens >= 3.8 && < 5,+ mtl >= 2.0 && < 2.3, old-locale >= 1.0 && < 1.1,- readable >= 0.1 && < 0.2,- snap >= 0.11 && < 0.13,- snap-core >= 0.9 && < 0.10,- snap-extras >= 0.5 && < 0.7,- template-haskell >= 2.4 && < 2.9,- text >= 0.11 && < 0.12,- time >= 1.4 && < 1.5,+ readable >= 0.1 && < 0.4,+ snap >= 0.11 && < 1.1,+ snap-core >= 0.9 && < 1.1,+ snap-extras >= 0.11 && < 0.13,+ template-haskell >= 2.4,+ text >= 0.11 && < 1.3,+ time >= 1.4 && < 1.9,+ time-locale-compat, xmlhtml >= 0.2 && < 0.3,- errors+ map-syntax ghc-options: -Wall -fwarn-tabs
src/Snap/Restful.hs view
@@ -20,6 +20,7 @@ , itemSplices , resourceCSplices , itemCSplices+ , itemCSplice , unitLens , resourceRouter , resourceRoutes@@ -50,11 +51,10 @@ -- * Misc helpers , redirToItem- , prefixSplices , relativeRedirect , setFormAction , getFormAction- , simpleDateFormlet+ ) where ------------------------------------------------------------------------------@@ -62,7 +62,7 @@ import qualified Blaze.ByteString.Builder.Char8 as Build import Control.Applicative import Control.Arrow-import Control.Error+import Control.Error hiding (bool) import Control.Lens import Control.Monad import Control.Monad.Trans@@ -72,15 +72,17 @@ import Data.Default import Data.Int import qualified Data.Map as M+import qualified Data.Map.Syntax as MS import Data.Monoid import Data.Readable import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Time+import qualified Data.Time.Locale.Compat as LC import Data.Typeable import Data.Word-import Heist+import Heist hiding (Error) import qualified Heist.Compiled as C import qualified Heist.Interpreted as I import Snap.Core@@ -95,17 +97,6 @@ --------------------------------------------------------------------------------- | Adds a prefix to the tag names for a list of splices. If the existing--- tag name is empty, then the new tag name is just the prefix. Otherwise the--- new tag name is the prefix followed by an underscore followed by the--- existing name.-prefixSplices :: Text -> [(Text, a)] -> [(Text, a)]-prefixSplices prefix = map f- where- f (t,v) = if T.null t then (prefix,v) else (T.concat [prefix,"_",t], v)--------------------------------------------------------------------------------- -- | Enumeration of all the different types of CRUD routes. data CRUD = RIndex -- ^ An item index@@ -254,8 +245,8 @@ -> Initializer b v () addResource' f res rHandlers rResourceActions rItemActions h = do addRoutes $ f res rHandlers rResourceActions rItemActions- addConfig h mempty { hcInterpretedSplices = resourceSplices res- , hcCompiledSplices = resourceCSplices res }+ addConfig h $ mempty & scInterpretedSplices .~ resourceSplices res+ & scCompiledSplices .~ resourceCSplices res ------------------------------------------------------------------------------@@ -347,12 +338,12 @@ templatePath :: Resource -> CRUD -> ByteString templatePath Resource{..} crud = case crud of- RIndex -> mkPathB [r, "index"]- RCreate -> error "Create action does not get a template."- RShow -> mkPathB [r, "show"]- RNew -> mkPathB [r, "new"]- REdit -> mkPathB [r, "edit"]- RUpdate -> error "Update action does not get a template."+ RIndex -> mkPathB [r, "index"]+ RCreate -> error "Create action does not get a template."+ RShow -> mkPathB [r, "show"]+ RNew -> mkPathB [r, "new"]+ REdit -> mkPathB [r, "edit"]+ RUpdate -> error "Update action does not get a template." RDestroy -> error "Destroy action does not get a template." where r = T.encodeUtf8 rRoot@@ -418,7 +409,7 @@ --------------------------------------------------------------------------------- | Sets the @RESTFormAction@ param. +-- | Sets the @RESTFormAction@ param. setFormAction :: MonadSnap m => Text -> m a -> m a setFormAction a = localRequest f where@@ -426,7 +417,7 @@ (rqParams req) } --------------------------------------------------------------------------------- | Gets the @RESTFormAction@ param. +-- | Gets the @RESTFormAction@ param. getFormAction :: MonadSnap m => HeistT n m [X.Node] getFormAction = do p <- lift $ getParam "RESTFormAction"@@ -435,80 +426,89 @@ ------------------------------------------------------------------------------- -- | Paths at the resource/collection level-resourceSplices :: Monad m => Resource -> [(Text, HeistT n m Template)]+resourceSplices :: Monad m => Resource -> Splices (HeistT n m Template) resourceSplices r@Resource{..} =- map (mkResourceActionSplice r) rResourceEndpoints ++- [ (T.concat [rName, "NewPath"], I.textSplice $ newPath r)- , (T.concat [rName, "IndexPath"], I.textSplice $ indexPath r)- , (T.concat [rName, "CreatePath"], I.textSplice $ createPath r)- , (T.concat [rName, "Path"], I.textSplice $ rootPath r)- ]+ sequence_ (map (mkResourceActionSplice r) rResourceEndpoints) `mappend` a+ where+ a = do+ T.concat [rName, "NewPath"] MS.## I.textSplice $ newPath r+ T.concat [rName, "IndexPath"] MS.## I.textSplice $ indexPath r+ T.concat [rName, "CreatePath"] MS.## I.textSplice $ createPath r+ T.concat [rName, "Path"] MS.## I.textSplice $ rootPath r + ------------------------------------------------------------------------------ -- | Generates path splices for a resource item. These splices let you put -- resource links in your templates in DRY manner.-itemSplices :: Monad m => Resource -> DBId -> [(Text, I.Splice m)]+itemSplices :: Monad m => Resource -> DBId -> Splices (I.Splice m) itemSplices r@Resource{..} dbid =- map (mkItemActionSplice r dbid) rItemEndpoints ++- [ (T.concat [rName, "ItemEditPath"], I.textSplice $ editPath r dbid)- , (T.concat [rName, "ItemShowPath"], I.textSplice $ showPath r dbid)- , (T.concat [rName, "ItemUpdatePath"], I.textSplice $ updatePath r dbid)- , (T.concat [rName, "ItemDestroyPath"], I.textSplice $ destroyPath r dbid)- , (T.concat [rName, "ItemNewPath"], I.textSplice $ newPath r)- , (T.concat [rName, "ItemIndexPath"], I.textSplice $ indexPath r)- , (T.concat [rName, "ItemCreatePath"], I.textSplice $ createPath r)- ]+ sequence_ (map (mkItemActionSplice r dbid) rItemEndpoints) `mappend` a+ where+ a = do+ T.concat [rName, "ItemEditPath"] MS.## I.textSplice $ editPath r dbid+ T.concat [rName, "ItemShowPath"] MS.## I.textSplice $ showPath r dbid+ T.concat [rName, "ItemUpdatePath"] MS.## I.textSplice $ updatePath r dbid+ T.concat [rName, "ItemDestroyPath"] MS.## I.textSplice $ destroyPath r dbid+ T.concat [rName, "ItemNewPath"] MS.## I.textSplice $ newPath r+ T.concat [rName, "ItemIndexPath"] MS.## I.textSplice $ indexPath r+ T.concat [rName, "ItemCreatePath"] MS.## I.textSplice $ createPath r ------------------------------------------------------------------------------- -- | Returns compiled splices for a resource.-resourceCSplices :: MonadSnap m => Resource -> [(Text, C.Splice m)]-resourceCSplices r = C.mapSnd (C.runNodeList =<<) $ resourceSplices r+resourceCSplices :: MonadSnap m => Resource -> Splices (C.Splice m)+resourceCSplices r = MS.mapV (C.runNodeList =<<) $ resourceSplices r ------------------------------------------------------------------------------ -- | Generates compiled path splices for a resource item. These splices let -- you put resource links in your templates in DRY manner.-itemCSplices :: Resource- -> [(Text, DBId -> Text)]-itemCSplices r@Resource{..} =- [ (T.concat [rName, "ItemEditPath"], editPath r)- , (T.concat [rName, "ItemShowPath"], showPath r)- , (T.concat [rName, "ItemUpdatePath"], updatePath r)- , (T.concat [rName, "ItemDestroyPath"], destroyPath r)- ] ++- C.mapSnd const- [ (T.concat [rName, "ItemNewPath"], newPath r)- , (T.concat [rName, "ItemIndexPath"], indexPath r)- , (T.concat [rName, "ItemCreatePath"], createPath r)- ] ++- map (mkItemActionCSplice r) rItemEndpoints+itemCSplices :: Resource -> Splices (Maybe DBId -> Text)+itemCSplices r@Resource{..} = a `mappend` b `mappend` c+ where+ a = do+ T.concat [rName, "ItemEditPath"] MS.## maybe "" (editPath r)+ T.concat [rName, "ItemShowPath"] MS.## maybe "" (showPath r)+ T.concat [rName, "ItemUpdatePath"] MS.## maybe "" (updatePath r)+ T.concat [rName, "ItemDestroyPath"] MS.## maybe "" (destroyPath r)+ b = MS.mapV const $ do+ T.concat [rName, "ItemNewPath"] MS.## newPath r+ T.concat [rName, "ItemIndexPath"] MS.## indexPath r+ T.concat [rName, "ItemCreatePath"] MS.## createPath r+ c = sequence_ $ map (mkItemActionCSplice r) rItemEndpoints +------------------------------------------------------------------------------+-- | A splice that runs its children with all item splices for a resource.+-- This function gets the id from the \"id\" param, which could have come in+-- the request or might have been set up by a route capture string.+itemCSplice r =+ C.withSplices C.runChildren (MS.mapV (C.pureSplice . C.textSplice) $ itemCSplices r) $ do+ mid <- lift $ getParam "id"+ return $ fromBS =<< mid++ ------------------------------------------------------------------------------- -- | Splices to generate links for resource item actions. mkItemActionSplice :: Monad m- => Resource -> DBId -> Text -> (Text, I.Splice m)+ => Resource -> DBId -> Text -> Splices (I.Splice m) mkItemActionSplice r@Resource{..} dbid t =- ( T.concat [rName, "Item", cap t, "Path"]- , I.textSplice $ itemActionPath r t dbid)+ T.concat [rName, "Item", cap t, "Path"] MS.## I.textSplice $ itemActionPath r t dbid ------------------------------------------------------------------------------- -- | Compiled splices to generate links for resource actions.-mkResourceActionSplice :: Monad m => Resource -> Text -> (Text, HeistT n m Template)+mkResourceActionSplice :: Monad m => Resource -> Text -> Splices (HeistT n m Template) mkResourceActionSplice r@Resource{..} t =- ( T.concat [rName, cap t, "Path"]- , I.textSplice $ resourceActionPath r t)+ T.concat [rName, cap t, "Path"] MS.## I.textSplice $ resourceActionPath r t ------------------------------------------------------------------------------- -- | Compiled splices to generate links for resource item actions.-mkItemActionCSplice :: Resource -> Text -> (Text, DBId -> Text)+mkItemActionCSplice :: Resource -> Text -> Splices (Maybe DBId -> Text) mkItemActionCSplice r@Resource{..} t =- ( T.concat [rName, "Item", cap t, "Path"]- , itemActionPath r t)+ T.concat [rName, "Item", cap t, "Path"] MS.## maybe mempty (itemActionPath r t) ------------------------------------------------------------------------------@@ -527,7 +527,7 @@ cap t = case T.uncons t of Just (h, rest) -> T.cons (toUpper h) rest- Nothing -> t+ Nothing -> t relativeRedirect :: MonadSnap m => B.ByteString -> m b@@ -549,6 +549,8 @@ instance HasFormlet Double where formlet = stringRead "must be a double" instance HasFormlet Bool where formlet = bool +instance HasFormlet ByteString where+ formlet v = validate (Success . T.encodeUtf8) $ text (T.decodeUtf8 <$> v) instance HasFormlet Int8 where formlet = stringRead "must be an integer" instance HasFormlet Int16 where@@ -568,19 +570,16 @@ validDate :: Text -> Result Text Day validDate = maybe (Error "invalid date") Success .- parseTime defaultTimeLocale "%F" . T.unpack+ parseTime LC.defaultTimeLocale "%F" . T.unpack dayText :: Day -> Text-dayText = T.pack . formatTime defaultTimeLocale "%F"+dayText = T.pack . formatTime LC.defaultTimeLocale "%F" --------------------------------------------------------------------------------- | A simple formlet for dates that-simpleDateFormlet :: (Monad m)- => Maybe Day -> Form Text m Day-simpleDateFormlet d = validate validDate $- text (dayText <$> d)+-- Splices+------------------------------------------------------------------------------ ------------------------------------------------------------------------------
src/Snap/Restful/TH.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-}@@ -30,24 +31,29 @@ info <- reify n case info of TyConI dec -> decCons dec- _ -> return []+ _ -> return [] ------------------------------------------------------------------------------ -- | Gets a list of constructors for a Dec. decCons :: Dec -> Q [Con]-decCons (DataD _ _ _ cons _) = return cons+#if MIN_VERSION_template_haskell(0, 11, 0)+decCons (DataD _ _ _ _ cons _) = return cons+decCons (NewtypeD _ _ _ _ con _) = return [con]+#else+decCons (DataD _ _ _ cons _) = return cons decCons (NewtypeD _ _ _ con _) = return [con]-decCons (TySynD _ _ t) = typeCons t-decCons _ = return []+#endif+decCons (TySynD _ _ t) = typeCons t+decCons _ = return [] ------------------------------------------------------------------------------ -- | Gets a list of constructors for a Type. typeCons :: Type -> Q [Con] typeCons (AppT a _) = typeCons a-typeCons (ConT n) = nameCons n-typeCons _ = return []+typeCons (ConT n) = nameCons n+typeCons _ = return [] ------------------------------------------------------------------------------@@ -66,7 +72,11 @@ splat = VarE '(<*>) res = foldl (\a b -> UInfixE a splat b) start fs func = [FunD 'formlet [Clause [VarP defName] (NormalB res) []]]+#if MIN_VERSION_template_haskell(0, 11, 0)+ return $ [InstanceD Nothing [] (AppT (ConT ''HasFormlet) (ConT n)) func]+#else return $ [InstanceD [] (AppT (ConT ''HasFormlet) (ConT n)) func]+#endif _ -> error "You can only generate formlets for a data type with a single constructor and named record fields" @@ -84,11 +94,12 @@ case cons of [RecC conName fields] -> do param <- newName "x"- let fieldToTuple (fn,_,_) = do+ let fieldToSplice (fn,_,_) = do f <- [| iPrimSplice $ $(appE (varE fn) (varE param)) |]- return $ TupE [LitE $ StringL $ nameBase fn, f]- fs <- mapM fieldToTuple fields- return $ LamE [VarP param] (ListE fs)+-- return $ TupE [LitE $ StringL $ nameBase fn, f]+ return $ NoBindS $ UInfixE (LitE $ StringL $ nameBase fn) (VarE $ mkName "##") f+ fs <- mapM fieldToSplice fields+ return $ LamE [VarP param] (DoE fs) _ -> error "You can only generate splices for a data type with a single constructor and named record fields" @@ -104,11 +115,12 @@ cons <- nameCons n case cons of [RecC conName fields] -> do- let fieldToTuple (fn,_,_) = do+ let fieldToSplice (fn,_,_) = do f <- [| cPrimSplice . $(varE fn) |]- return $ TupE [LitE $ StringL $ nameBase fn, f]- fs <- mapM fieldToTuple fields- return $ ListE fs+-- return $ TupE [LitE $ StringL $ nameBase fn, f]+ return $ NoBindS $ UInfixE (LitE $ StringL $ nameBase fn) (VarE $ mkName "##") f+ fs <- mapM fieldToSplice fields+ return $ DoE fs _ -> error "You can only generate splices for a data type with a single constructor and named record fields"