diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,5 @@ +0.4.1 +* Bump various dependency upper bounds. + +0.4 +* Support newer versions of heist diff --git a/restful-snap.cabal b/restful-snap.cabal --- a/restful-snap.cabal +++ b/restful-snap.cabal @@ -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 diff --git a/src/Snap/Restful.hs b/src/Snap/Restful.hs --- a/src/Snap/Restful.hs +++ b/src/Snap/Restful.hs @@ -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 +------------------------------------------------------------------------------ ------------------------------------------------------------------------------ diff --git a/src/Snap/Restful/TH.hs b/src/Snap/Restful/TH.hs --- a/src/Snap/Restful/TH.hs +++ b/src/Snap/Restful/TH.hs @@ -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"