diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/restful-snap.cabal b/restful-snap.cabal new file mode 100644 --- /dev/null +++ b/restful-snap.cabal @@ -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 diff --git a/src/Snap/Restful.hs b/src/Snap/Restful.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Restful.hs @@ -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 + + diff --git a/src/Snap/Restful/TH.hs b/src/Snap/Restful/TH.hs new file mode 100644 --- /dev/null +++ b/src/Snap/Restful/TH.hs @@ -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" + + +