restful-snap (empty) → 0.1.1
raw patch · 5 files changed
+846/−0 lines, 5 filesdep +basedep +blaze-builderdep +bytestringsetup-changed
Dependencies added: base, blaze-builder, bytestring, containers, data-default, digestive-functors, errors, heist, lens, mtl, old-locale, readable, snap, snap-core, snap-extras, template-haskell, text, time, xmlhtml
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- restful-snap.cabal +46/−0
- src/Snap/Restful.hs +657/−0
- src/Snap/Restful/TH.hs +111/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2012, Ozgun Ataman++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 Ozgun Ataman 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
+ restful-snap.cabal view
@@ -0,0 +1,46 @@+name: restful-snap+version: 0.1.1+description: A convention-based RESTful routing mechanism for snap+license: BSD3+license-file: LICENSE+author: Ozgun Ataman, Doug Beardsley+maintainer: ozataman@gmail.com+copyright: Soostone Inc+category: Web, Snap+build-type: Simple+cabal-version: >=1.8+homepage: https://github.com/ozataman/restful-snap++source-repository head+ type: git+ location: https://github.com/ozataman/restful-snap.git++library+ hs-source-dirs: src++ exposed-modules: + Snap.Restful+ Snap.Restful.TH++ build-depends: + base >= 4 && < 5,+ blaze-builder >= 0.3 && < 0.4,+ 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,+ 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.6,+ template-haskell >= 2.4 && < 2.9,+ text >= 0.11 && < 0.12,+ time >= 1.4 && < 1.5,+ xmlhtml >= 0.2 && < 0.3,+ errors++ ghc-options: -Wall -fwarn-tabs
+ src/Snap/Restful.hs view
@@ -0,0 +1,657 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Snap.Restful+ ( CRUD (..)+ , Resource (..)+ , DBId (..)+ , HasFormlet (..)+ , PrimSplice (..)+ , iPrimText+ , iPrimShow+ , cPrimShow++ , addResource+ , addResourceRelative+ , initRest+ , unitLens+ , resourceRouter+ , resourceRoutes++ , rootPath+ , indexPath+ , createPath+ , showPath+ , newPath+ , editPath+ , updatePath+ , destroyPath+ , itemActionPath++ , templatePath++ , resourceSplices+ , itemSplices+ , resourceCSplices+ , itemCSplices++ , redirToItem++ , prefixSplices++ , relativeRedirect++ , setFormAction+ , getFormAction++ , simpleDateFormlet+ ) where++------------------------------------------------------------------------------+import Blaze.ByteString.Builder+import qualified Blaze.ByteString.Builder.Char8 as Build+import Control.Applicative+import Control.Arrow+import Control.Error+import Control.Lens+import Control.Monad+import Control.Monad.Trans+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as B+import Data.Char (toUpper)+import Data.Default+import Data.Int+import qualified Data.Map as M+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 Data.Typeable+import Data.Word+import Heist+import qualified Heist.Compiled as C+import qualified Heist.Interpreted as I+import Snap.Core+import Snap.Extras.CoreUtils+import Snap.Snaplet+import Snap.Snaplet.Heist+import System.Locale+import Text.Digestive+import qualified Text.XmlHtml as X+------------------------------------------------------------------------------++++------------------------------------------------------------------------------+-- | 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+ | RShow+ -- ^ A single item+ | RNew+ -- ^ The form for creating a new item+ | REdit+ -- ^ The form for editing an item+ | RCreate+ -- ^ Create a new item+ | RUpdate+ -- ^ Update an item+ | RDestroy+ -- ^ Delete an item+ deriving (Eq,Show,Read,Ord)+++newtype DBId = DBId { unDBId :: Word64 }+ deriving (Eq,Show,Read,Ord,Num,Typeable)+++instance Default DBId where+ def = DBId 0++instance Readable DBId where fromText = return . DBId <=< fromText+++------------------------------------------------------------------------------+-- | Encapsulates the data necessary to define a resource.+data Resource = Resource {+ rName :: Text+ -- ^ A name for this resource+ , rRoot :: Text+ -- ^ URL root for this resource+ , rResourceEndpoints :: [Text]+ -- ^ Resource level routing end points+ , rItemEndpoints :: [Text]+ -- ^ Item/instance level routing end points+}+++instance Default Resource where+ def = Resource "items" "/items" [] []+++------------------------------------------------------------------------------+-- | An initializer for encapsulating RESTful resources as a standalone+-- snaplet.+initRest :: HasHeist b+ => Resource+ -> [(CRUD, Handler b () ())]+ -> [(Text, Handler b () ())]+ -> [(Text, Handler b () ())]+ -> Snaplet (Heist b)+ -> SnapletInit b ()+initRest res rHandlers rResourceActions rItemActions h =+ makeSnaplet (T.concat [rName res, "-resource"])+ (T.concat ["RESTful resource for ", rName res])+ Nothing $ addResource' resourceRoutesRelative res+ rHandlers rResourceActions rItemActions h+++------------------------------------------------------------------------------+-- | Since 'initRest' returns unit, we provide a generic unit lens here for+-- use with nestSnaplet in case you don't want to add a unit field to your+-- application state type.+unitLens :: Lens' b ()+unitLens = lens (const ()) (\a () -> a)+++------------------------------------------------------------------------------+-- We need two addResource functions because we are dealing with paths in two+-- different contexts: routes and splices. With routes, the addRoutes+-- function automatically makes things relative to the current snaplet root.+-- But that will only take effect when initRest is used, and is therefore+-- inside a nestSnaplet call.+--+-- For paths inside splices, the snaplet addRoute infrastructure is not+-- available because these splices always run in the Handler App App monad and+-- therefore can't have access to the current snaplet root.+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- | One-stop convenience function to enable RESTful resources in your+-- application. Call this function from your initializer passing it all of+-- your resources and it will add the routes and splices for you.+addResource :: HasHeist b+ => Resource+ -- ^ Resource definition+ -> [(CRUD, Handler b v ())]+ -- ^ Standard CRUD handlers+ -> [(Text, Handler b v ())]+ -- ^ Additional resource level handlers+ -> [(Text, Handler b v ())]+ -- ^ Additional instance/item level handlers+ -> Snaplet (Heist b)+ -- ^ The Heist snaplet initialized in your app's 'Initializer'+ -> Initializer b v ()+addResource res rHandlers rResourceActions rItemActions h = do+ addRoutes $ [((T.encodeUtf8 $ rRoot res) -/- ":id/:action", restfulHeistServe res)]+ addResource' resourceRoutes res rHandlers rResourceActions rItemActions h+++------------------------------------------------------------------------------+-- | Just like 'addResource', but makes the handlers relative to the current+-- snaplet's root. Use this function if you're writing a snaplet.+addResourceRelative :: HasHeist b+ => Resource+ -- ^ Resource definition+ -> [(CRUD, Handler b v ())]+ -- ^ Standard CRUD handlers+ -> [(Text, Handler b v ())]+ -- ^ Additional resource level handlers+ -> [(Text, Handler b v ())]+ -- ^ Additional instance/item level handlers+ -> Snaplet (Heist b)+ -- ^ The Heist snaplet initialized in your app's+ -- 'Initializer'+ -> Initializer b v ()+addResourceRelative res rHandlers rResourceActions rItemActions h = do+ addRoutes $ [(":id/:action", restfulHeistServe res)]+ addResource' resourceRoutesRelative res rHandlers rResourceActions rItemActions h+++-------------------------------------------------------------------------------+-- | Serves the routes for a resource with heist templates.+restfulHeistServe :: HasHeist b => Resource -> Handler b v ()+restfulHeistServe res = do+ x <- runMaybeT $ do+ action <- MaybeT $ getParam "action"+ lift $ render $ mkPathB [T.encodeUtf8 (rRoot res), action]+ maybe mzero return x+++------------------------------------------------------------------------------+-- | Helper function that can be used with resourceRoutes or+-- resourceRoutesRelative.+addResource' :: (Resource -> r -> s -> t -> [(ByteString, Handler b v ())])+ -> Resource+ -> r+ -> s+ -> t+ -> Snaplet (Heist b)+ -> 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 }+++------------------------------------------------------------------------------+-- | See 'addResource' for an explanation of the arguments to this+-- function. The routes returned ARE prefixed with rRoot from+-- Resource.+resourceRoutes+ :: MonadSnap m+ => Resource+ -> [(CRUD, m a)]+ -> [(Text, m a)]+ -> [(Text, m a)]+ -> [(ByteString, m a)]+resourceRoutes r rHandlers rResourceActions rItemActions =+ map (first $ (T.encodeUtf8 (rRoot r) -/-))+ (resourceRoutesRelative r rHandlers rResourceActions rItemActions)+++------------------------------------------------------------------------------+-- | See 'addResource' for an explanation of the arguments to this function.+-- The routes returned are not prefixed with rRoot from Resource.+resourceRoutesRelative+ :: MonadSnap m+ => Resource+ -> [(CRUD, m a)]+ -> [(Text, m a)]+ -> [(Text, m a)]+ -> [(ByteString, m a)]+resourceRoutesRelative r rHandlers rResourceActions rItemActions =+ map (mkCrudRoute r) rHandlers +++ map (mkResourceRoute r) rResourceActions +++ map (mkItemRoute r) rItemActions+++------------------------------------------------------------------------------+-- | Generate a route handler for the routes returned by resourceRoutes. This+-- function does add the rRoot prefix.+resourceRouter :: MonadSnap m+ => Resource+ -> [(CRUD, m a)]+ -> [(Text, m a)]+ -> [(Text, m a)]+ -> m a+resourceRouter r as bs cs = route $ resourceRoutes r as bs cs+++mkPath :: [Text] -> Text+mkPath = T.intercalate "/" . filter (not . T.null)++mkPathB :: [ByteString] -> ByteString+mkPathB = B.intercalate "/" . filter (not . B.null)++------------------------------------------------------------------------------+mkItemRoute :: Resource -> (Text, t3) -> (ByteString, t3)+mkItemRoute Resource{..} (actionName, h) =+ (T.encodeUtf8 $ mkPath [":id", actionName], h)+++------------------------------------------------------------------------------+mkResourceRoute :: Resource -> (Text, t3) -> (ByteString, t3)+mkResourceRoute Resource{..} (actionName, h) =+ (T.encodeUtf8 $ mkPath [actionName], h)+++------------------------------------------------------------------------------+mkCrudRoute :: MonadSnap m+ => Resource -> (CRUD, m a) -> (ByteString, m a)+mkCrudRoute r@Resource{..} (crud, h) =+ case crud of+ RIndex -> ("", ifTop $ method GET h)+ RCreate -> ( "", ifTop $ method POST (setCreateAction h))+ RShow -> ( ":id", ifTop $ method GET h)+ RNew -> ( "new", ifTop $ method GET (setCreateAction h))+ REdit -> ( T.encodeUtf8 $ mkPath [":id", "edit"]+ , ifTop $ method GET (setEditAction h))+ RUpdate -> ( T.encodeUtf8 $ mkPath [":id"]+ , ifTop $ method POST (setEditAction h))+ RDestroy -> ( T.encodeUtf8 $ mkPath [":id", "destroy"]+ , ifTop $ method POST h)+ where+ setCreateAction h2 = setFormAction (createPath r) h2+ setEditAction h2 = do+ _id <- getParam "id"+ maybe h2 (\i -> setFormAction (updatePath r (DBId i)) h2) (fromBS =<<_id)+++------------------------------------------------------------------------------+-- | Return heist template location for given crud action+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."+ RDestroy -> error "Destroy action does not get a template."+ where+ r = T.encodeUtf8 rRoot+++resourceActionPath :: Resource -> Text -> Text+resourceActionPath Resource{..} t = mkPath [rRoot, t]+++------------------------------------------------------------------------------+-- | Generates a path for an item action.+itemActionPath :: Resource -> Text -> DBId -> Text+itemActionPath Resource{..} t DBId{..} =+ mkPath [rRoot, showT unDBId, t]+++------------------------------------------------------------------------------+-- | Generates the path for the resource index.+indexPath :: Resource -> Text+indexPath r = rRoot r+++------------------------------------------------------------------------------+-- | Generates the path for creating a resource.+createPath :: Resource -> Text+createPath r = rRoot r+++------------------------------------------------------------------------------+-- | Generates the path for a form to a new resource.+newPath :: Resource -> Text+newPath r = mkPath [rRoot r, "new"]+++------------------------------------------------------------------------------+-- | Same as 'indexPath'.+rootPath :: Resource -> Text+rootPath = indexPath+++------------------------------------------------------------------------------+-- | Generates the path for a form to a new resource.+editPath :: Resource -> DBId -> Text+editPath r (DBId _id) = mkPath [rRoot r, showT _id, "edit"]+++------------------------------------------------------------------------------+-- | Generates the path for showing a single resource item.+showPath :: Resource -> DBId -> Text+showPath r (DBId _id) = mkPath [rRoot r, showT _id]+++------------------------------------------------------------------------------+-- | Generates the path for updating a single resource item.+updatePath :: Resource -> DBId -> Text+updatePath r (DBId _id) = mkPath [rRoot r, showT _id]+++------------------------------------------------------------------------------+-- | Generates the path for deleting a resource item.+destroyPath :: Resource -> DBId -> Text+destroyPath r (DBId _id) = mkPath [rRoot r, showT _id, "destroy"]+++------------------------------------------------------------------------------+-- | Sets the @RESTFormAction@ param. +setFormAction :: MonadSnap m => Text -> m a -> m a+setFormAction a = localRequest f+ where+ f req = req { rqParams = M.insert "RESTFormAction" [T.encodeUtf8 a]+ (rqParams req) }++------------------------------------------------------------------------------+-- | Gets the @RESTFormAction@ param. +getFormAction :: MonadSnap m => HeistT n m [X.Node]+getFormAction = do+ p <- lift $ getParam "RESTFormAction"+ maybe (return []) (I.textSplice . T.decodeUtf8) p+++-------------------------------------------------------------------------------+-- | Paths at the resource/collection level+resourceSplices :: Monad m => Resource -> [(Text, 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)+ ]+++------------------------------------------------------------------------------+-- | 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 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)+ ]+++-------------------------------------------------------------------------------+-- | Returns compiled splices for a resource.+resourceCSplices :: MonadSnap m => Resource -> [(Text, C.Splice m)]+resourceCSplices r = C.mapSnd (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+++-------------------------------------------------------------------------------+-- | Splices to generate links for resource item actions.+mkItemActionSplice :: Monad m+ => Resource -> DBId -> Text -> (Text, I.Splice m)+mkItemActionSplice r@Resource{..} dbid t =+ ( T.concat [rName, "Item", cap t, "Path"]+ , 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 r@Resource{..} t =+ ( T.concat [rName, cap t, "Path"]+ , I.textSplice $ resourceActionPath r t)+++-------------------------------------------------------------------------------+-- | Compiled splices to generate links for resource item actions.+mkItemActionCSplice :: Resource -> Text -> (Text, DBId -> Text)+mkItemActionCSplice r@Resource{..} t =+ ( T.concat [rName, "Item", cap t, "Path"]+ , itemActionPath r t)+++------------------------------------------------------------------------------+-- | Redirect to given item's default show page+redirToItem :: MonadSnap m => Resource -> DBId -> m a+redirToItem r dbid = redirect . T.encodeUtf8 $ showPath r dbid+++------------------------------------------------------------------------------+showT :: Show a => a -> Text+showT = T.pack . show+++------------------------------------------------------------------------------+cap :: Text -> Text+cap t =+ case T.uncons t of+ Just (h, rest) -> T.cons (toUpper h) rest+ Nothing -> t+++relativeRedirect :: MonadSnap m => B.ByteString -> m b+relativeRedirect _path = do+ root <- withRequest (return . rqContextPath)+ redirect $ root `B.append` _path+++------------------------------------------------------------------------------+-- | Type class for automatic formlet generation.+class HasFormlet a where+ formlet :: Monad m => Formlet Text m a++instance HasFormlet String where formlet = string+instance HasFormlet Text where formlet = text+instance HasFormlet Int where formlet = stringRead "must be an integer"+instance HasFormlet Integer where formlet = stringRead "must be an integer"+instance HasFormlet Float where formlet = stringRead "must be a float"+instance HasFormlet Double where formlet = stringRead "must be a double"+instance HasFormlet Bool where formlet = bool++instance HasFormlet Int8 where+ formlet = stringRead "must be an integer"+instance HasFormlet Int16 where+ formlet = stringRead "must be an integer"+instance HasFormlet Int32 where+ formlet = stringRead "must be an integer"+instance HasFormlet Int64 where+ formlet = stringRead "must be an integer"+instance HasFormlet Word8 where+ formlet = stringRead "must be a positive integer"+instance HasFormlet Word16 where+ formlet = stringRead "must be a positive integer"+instance HasFormlet Word32 where+ formlet = stringRead "must be a positive integer"+instance HasFormlet Word64 where+ formlet = stringRead "must be a positive integer"++validDate :: Text -> Result Text Day+validDate = maybe (Error "invalid date") Success .+ parseTime defaultTimeLocale "%F" . T.unpack+++dayText :: Day -> Text+dayText = T.pack . formatTime defaultTimeLocale "%F"+++------------------------------------------------------------------------------+-- | A simple formlet for dates that+simpleDateFormlet :: (Monad m)+ => Maybe Day -> Form Text m Day+simpleDateFormlet d = validate validDate $+ text (dayText <$> d)+++------------------------------------------------------------------------------+-- | Type class for automatic splice generation.+class PrimSplice a where+ iPrimSplice :: Monad m => a -> m [X.Node]+ cPrimSplice :: a -> Builder++iPrimText :: Monad m => Text -> m [X.Node]+iPrimText t = return [X.TextNode t]+iPrimShow :: (Monad m, Show a) => a -> m [X.Node]+iPrimShow = iPrimText . T.pack . show++cPrimShow :: Show a => a -> Builder+cPrimShow x = Build.fromString $ show x++instance PrimSplice String where+ iPrimSplice x = iPrimText $ T.pack x+ cPrimSplice x = Build.fromText $ T.pack x+instance PrimSplice Text where+ iPrimSplice x = iPrimText x+ cPrimSplice x = Build.fromText x+instance PrimSplice Int where+ iPrimSplice x = iPrimShow x+ cPrimSplice = cPrimShow+instance PrimSplice Integer where+ iPrimSplice x = iPrimShow x+ cPrimSplice = cPrimShow+instance PrimSplice Float where+ iPrimSplice x = iPrimShow x+ cPrimSplice = cPrimShow+instance PrimSplice Double where+ iPrimSplice x = iPrimShow x+ cPrimSplice = cPrimShow+instance PrimSplice Bool where+ iPrimSplice x = iPrimShow x+ cPrimSplice = cPrimShow++instance PrimSplice Int8 where+ iPrimSplice x = iPrimShow x+ cPrimSplice = cPrimShow+instance PrimSplice Int16 where+ iPrimSplice x = iPrimShow x+ cPrimSplice = cPrimShow+instance PrimSplice Int32 where+ iPrimSplice x = iPrimShow x+ cPrimSplice = cPrimShow+instance PrimSplice Int64 where+ iPrimSplice x = iPrimShow x+ cPrimSplice = cPrimShow++instance PrimSplice Word8 where+ iPrimSplice x = iPrimShow x+ cPrimSplice = cPrimShow+instance PrimSplice Word16 where+ iPrimSplice x = iPrimShow x+ cPrimSplice = cPrimShow+instance PrimSplice Word32 where+ iPrimSplice x = iPrimShow x+ cPrimSplice = cPrimShow+instance PrimSplice Word64 where+ iPrimSplice x = iPrimShow x+ cPrimSplice = cPrimShow++instance PrimSplice Day where+ iPrimSplice = iPrimSplice . dayText+ cPrimSplice = cPrimSplice . dayText+instance PrimSplice UTCTime where+ iPrimSplice = iPrimShow+ cPrimSplice = cPrimShow++instance PrimSplice a => PrimSplice (Maybe a) where+ iPrimSplice Nothing = iPrimText ""+ iPrimSplice (Just x) = iPrimSplice x+ cPrimSplice Nothing = mempty+ cPrimSplice (Just x) = cPrimSplice x++
+ src/Snap/Restful/TH.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Snap.Restful.TH where++------------------------------------------------------------------------------+import Control.Applicative+import Language.Haskell.TH+import Snap.Restful+import Text.Digestive+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- | Gets a list of constructors for a Name.+nameCons :: Name -> Q [Con]+nameCons n = do+ info <- reify n+ case info of+ TyConI dec -> decCons dec+ _ -> return []+++------------------------------------------------------------------------------+-- | Gets a list of constructors for a Dec.+decCons :: Dec -> Q [Con]+decCons (DataD _ _ _ cons _) = return cons+decCons (NewtypeD _ _ _ con _) = return [con]+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 []+++------------------------------------------------------------------------------+-- | Derives a HasFormlet instance for a data type.+deriveHasFormlet :: Name -> Q [Dec]+deriveHasFormlet n = do+ cons <- nameCons n+ case cons of+ [RecC conName fields] -> do+ defName <- newName "d"+ let fieldFormlet (fn,_,_) = do+ let name = litE $ StringL $ nameBase fn+ [| $name .: formlet ( $(varE fn) <$> $(varE defName) ) |]+ (f:fs) <- mapM fieldFormlet fields+ let start = UInfixE (ConE conName) (VarE '(<$>)) f+ splat = VarE '(<*>)+ res = foldl (\a b -> UInfixE a splat b) start fs+ func = [FunD 'formlet [Clause [VarP defName] (NormalB res) []]]+ return $ [InstanceD [] (AppT (ConT ''HasFormlet) (ConT n)) func]+ _ -> error "You can only generate formlets for a data type with a single constructor and named record fields"+++------------------------------------------------------------------------------+-- | Generates interpreted splices for a data type. All of the data type's+-- fields must be instances of the PrimSplice type class.+--+-- Usage:+--+-- > fooSplices :: Monad m => Foo -> [(Text, I.Splice m)]+-- > fooSplices = $(iSplices ''Foo)+iSplices :: Name -> Q Exp+iSplices n = do+ cons <- nameCons n+ case cons of+ [RecC conName fields] -> do+ param <- newName "x"+ let fieldToTuple (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)+ _ -> error "You can only generate splices for a data type with a single constructor and named record fields"+++------------------------------------------------------------------------------+-- | Generates compiled splices for a data type. All of the data type's+-- fields must be instances of the PrimSplice type class.+--+-- Usage:+--+-- > fooSplices = $(cSplices ''Foo)+cSplices :: Name -> Q Exp+cSplices n = do+ cons <- nameCons n+ case cons of+ [RecC conName fields] -> do+ let fieldToTuple (fn,_,_) = do+ f <- [| cPrimSplice . $(varE fn) |]+ return $ TupE [LitE $ StringL $ nameBase fn, f]+ fs <- mapM fieldToTuple fields+ return $ ListE fs+ _ -> error "You can only generate splices for a data type with a single constructor and named record fields"+++