Permalink
Browse files

Added type classes to aid the creation of forms and splices

  • Loading branch information...
1 parent 7624529 commit d85b3612370690473876769c22412c31828d49ad @mightybyte mightybyte committed Aug 29, 2012
Showing with 258 additions and 86 deletions.
  1. +15 −7 restful-snap.cabal
  2. +243 −79 src/Snap/Restful.hs
View
22 restful-snap.cabal
@@ -21,10 +21,18 @@ library
Snap.Restful
build-depends:
- base == 4.5.*
- , bytestring
- , data-default
- , heist
- , snap-core
- , snap
- , text
+ base >= 4 && < 5,
+ bytestring >= 0.8 && < 0.10,
+ containers >= 0.4 && < 0.5,
+ data-default >= 0.5 && < 0.6,
+ digestive-functors >= 0.5 && < 0.6,
+ ghc-prim >= 0.2 && < 0.3,
+ heist >= 0.8 && < 0.9,
+ mtl >= 2.0 && < 2.1,
+ readable >= 0.1 && < 0.2,
+ relational >= 0.0 && < 0.1,
+ snap-core >= 0.9 && < 0.10,
+ snap >= 0.9 && < 0.10,
+ text >= 0.11 && < 0.12
+
+ ghc-options: -Wall -fwarn-tabs
View
322 src/Snap/Restful.hs
@@ -1,5 +1,11 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeSynonymInstances #-}
module Snap.Restful
( CRUD (..)
@@ -11,7 +17,7 @@ module Snap.Restful
, resourceRoutes
, rootPath
- , crudPath
+-- , crudPath
, indexPath
, createPath
, showPath
@@ -28,22 +34,145 @@ module Snap.Restful
, itemSplices'
, redirToItem
+
+ , HasFormlet(..)
+ , HasSplices(..)
+ , prefixSplices
+ , liftSplices
+
+ , relativeRedirect
) where
--------------------------------------------------------------------------------
+------------------------------------------------------------------------------
+import Control.Applicative
import Control.Arrow
+import Control.Monad
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.Readable
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
+import Data.Typeable
+import Data.Word
+import GHC.Generics
+import Relational.Types
import Snap.Core
import Snap.Snaplet
import Snap.Snaplet.Heist
+import Text.Digestive
import Text.Templating.Heist
--------------------------------------------------------------------------------
+------------------------------------------------------------------------------
+
+
+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 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"
+
+instance HasFormlet PK32 where
+ formlet d = PK32 <$> stringRead "must be a primary key" (unPK32 <$> d)
+instance HasFormlet PK64 where
+ formlet d = PK64 <$> stringRead "must be a primary key" (unPK64 <$> d)
+instance HasFormlet FK32 where
+ formlet d = FK32 <$> stringRead "must be a foreign key" (unFK32 <$> d)
+instance HasFormlet FK64 where
+ formlet d = FK64 <$> stringRead "must be a foreign key" (unFK64 <$> d)
+
+
+------------------------------------------------------------------------------
+-- | Type class for uniform creation of splices. For primitives that don't
+-- have field names the splices should be a list with one element and an empty
+-- string for the tag name.
+class HasSplices a where
+ splices :: (Monad m) => a -> [(Text, Splice m)]
+
+instance HasSplices String where
+ splices x = [("", textSplice $ T.pack x)]
+instance HasSplices Text where
+ splices x = [("", textSplice x)]
+instance HasSplices Int where
+ splices x = [("", textSplice $ T.pack $ show x)]
+instance HasSplices Integer where
+ splices x = [("", textSplice $ T.pack $ show x)]
+instance HasSplices Float where
+ splices x = [("", textSplice $ T.pack $ show x)]
+instance HasSplices Double where
+ splices x = [("", textSplice $ T.pack $ show x)]
+
+instance HasSplices Int8 where
+ splices x = [("", textSplice $ T.pack $ show x)]
+instance HasSplices Int16 where
+ splices x = [("", textSplice $ T.pack $ show x)]
+instance HasSplices Int32 where
+ splices x = [("", textSplice $ T.pack $ show x)]
+instance HasSplices Int64 where
+ splices x = [("", textSplice $ T.pack $ show x)]
+
+instance HasSplices Word8 where
+ splices x = [("", textSplice $ T.pack $ show x)]
+instance HasSplices Word16 where
+ splices x = [("", textSplice $ T.pack $ show x)]
+instance HasSplices Word32 where
+ splices x = [("", textSplice $ T.pack $ show x)]
+instance HasSplices Word64 where
+ splices x = [("", textSplice $ T.pack $ show x)]
+
+instance HasSplices PK32 where
+ splices = splices . unPK32
+instance HasSplices PK64 where
+ splices = splices . unPK64
+instance HasSplices FK32 where
+ splices = splices . unFK32
+instance HasSplices FK64 where
+ splices = splices . unFK64
+
+instance HasSplices a => HasSplices (Maybe a) where
+ splices Nothing = [("", textSplice "")]
+ splices (Just x) = splices x
+
+
+liftSplices :: [(Text, HeistT (Handler b b) a)]
+ -> [(Text, SnapletHeist b v a)]
+liftSplices = map (second liftHeist)
+
+
+------------------------------------------------------------------------------
+-- | 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, Splice m)] -> [(Text, Splice m)]
+prefixSplices pre = map f
+ where
+ f (t,v) = if T.null t then (pre,v) else (T.concat [pre,"_",t], v)
+
data CRUD = RIndex
@@ -63,12 +192,15 @@ data CRUD = RIndex
deriving (Eq,Show,Read,Ord)
-newtype DBId = DBId { unDBId :: Int } deriving (Eq,Show,Read,Ord)
+newtype DBId = DBId { unDBId :: Word64 }
+ deriving (Eq,Show,Read,Ord,Num,Generic,Typeable)
instance Default DBId where
def = DBId 0
+instance Readable DBId where fromText = return . DBId <=< fromText
+
data Resource b v a = Resource {
rName :: Text
@@ -99,167 +231,199 @@ initRest resources = do
addRoutes routes
--------------------------------------------------------------------------------
+------------------------------------------------------------------------------
resourceRoutes :: Resource b v a -> [(ByteString, Handler b v a)]
resourceRoutes r@Resource{..} =
map (mkCrudRoute r) rHandlers ++
map (mkResourceRoute r) rResourceActions ++
map (mkItemRoute r) rItemActions
--------------------------------------------------------------------------------
+------------------------------------------------------------------------------
resourceRouter :: Resource b v a -> Handler b v a
resourceRouter = route . resourceRoutes
--------------------------------------------------------------------------------
+------------------------------------------------------------------------------
mkItemRoute Resource{..} (act, h) =
- (T.encodeUtf8 $ T.intercalate "/" [rRoot, ":id", act], h)
+ (T.encodeUtf8 $ T.intercalate "/" [rRoot, ":id", act], h)
--------------------------------------------------------------------------------
+------------------------------------------------------------------------------
mkResourceRoute Resource{..} (act, h) =
- (T.encodeUtf8 $ T.intercalate "/" [rRoot, act], h)
-
--------------------------------------------------------------------------------
-mkCrudRoute
- :: MonadSnap m
- => Resource b v a -> (CRUD, m a) -> (ByteString, m a)
-mkCrudRoute Resource{..} (crud, h) =
- case crud of
- RIndex -> (T.encodeUtf8 rRoot, ifTop $ method GET h)
- RCreate -> (T.encodeUtf8 rRoot, ifTop $ method POST h)
- RShow -> (T.encodeUtf8 $ T.intercalate "/" [rRoot, ":id"], ifTop $ method GET h)
- RNew -> (T.encodeUtf8 $ T.intercalate "/" [rRoot, "new"], ifTop $ method GET h)
- REdit -> (T.encodeUtf8 $ T.intercalate "/" [rRoot, ":id", "edit"], ifTop $ method GET h)
- RUpdate -> ( T.encodeUtf8 $ T.intercalate "/" [rRoot, ":id"], ifTop $ method POST h)
- RDestroy -> ( T.encodeUtf8 $ T.intercalate "/" [rRoot, ":id", "destroy"]
- , ifTop $ method POST h)
+ (T.encodeUtf8 $ T.intercalate "/" [rRoot, act], h)
+
+
+------------------------------------------------------------------------------
+mkCrudRoute :: MonadSnap m
+ => Resource b v a -> (CRUD, m a) -> (ByteString, m a)
+mkCrudRoute r@Resource{..} (crud, h) =
+ case crud of
+ RIndex -> (T.encodeUtf8 rRoot, ifTop $ method GET h)
+ RCreate -> ( T.encodeUtf8 rRoot
+ , ifTop $ method POST (setCreateAction h))
+ RShow -> ( T.encodeUtf8 $ T.intercalate "/" [rRoot, ":id"]
+ , ifTop $ method GET h)
+ RNew -> ( T.encodeUtf8 $ T.intercalate "/" [rRoot, "new"]
+ , ifTop $ method GET (setCreateAction h))
+ REdit -> ( T.encodeUtf8 $ T.intercalate "/" [rRoot, ":id", "edit"]
+ , ifTop $ method GET (setEditAction h))
+ RUpdate -> ( T.encodeUtf8 $ T.intercalate "/" [rRoot, ":id"]
+ , ifTop $ method POST (setEditAction h))
+ RDestroy -> ( T.encodeUtf8 $ T.intercalate "/" [rRoot, ":id", "destroy"]
+ , ifTop $ method POST h)
+ where
+ setCreateAction h = setFormAction (createPath r) h
+ setEditAction h = do
+ _id <- getParam "id"
+ maybe h (\i -> setFormAction (updatePath r (DBId i)) h) (fromBS =<<_id)
+------------------------------------------------------------------------------
-- | Return heist template location for given crud action
templatePath Resource{..} crud =
- case crud of
- RIndex -> B.intercalate "/" [r, "index"]
- RCreate -> error "Create action does not get a template."
- RShow -> B.intercalate "/" [r, "show"]
- RNew -> B.intercalate "/" [r, "new"]
- REdit -> B.intercalate "/" [r, "edit"]
- RUpdate -> error "Update action does not get a template."
- RDestroy -> error "Destroy action does not get a template."
+ case crud of
+ RIndex -> B.intercalate "/" [r, "index"]
+ RCreate -> error "Create action does not get a template."
+ RShow -> B.intercalate "/" [r, "show"]
+ RNew -> B.intercalate "/" [r, "new"]
+ REdit -> B.intercalate "/" [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
--------------------------------------------------------------------------------
-crudPath :: Resource b v a -> CRUD -> DBId -> Text
-crudPath Resource{..} crud DBId{..} =
- case crud of
- RIndex -> rRoot
- RCreate -> rRoot
- RShow -> T.intercalate "/" [rRoot, showT unDBId]
- RNew -> T.intercalate "/" [rRoot, "new"]
- REdit -> T.intercalate "/" [rRoot, showT unDBId, "edit"]
- RUpdate -> T.intercalate "/" [rRoot, showT unDBId]
- RDestroy -> T.intercalate "/" [rRoot, showT unDBId, "destroy"]
- x -> error $ "Unimplemented crudpath " ++ show x
+------------------------------------------------------------------------------
+--crudPath :: Resource b v a -> CRUD -> DBId -> Text
+--crudPath Resource{..} crud DBId{..} =
+-- case crud of
+-- RIndex -> rRoot
+-- RCreate -> rRoot
+-- RShow -> T.intercalate "/" [rRoot, showT unDBId]
+-- RNew -> T.intercalate "/" [rRoot, "new"]
+-- REdit -> T.intercalate "/" [rRoot, showT unDBId, "edit"]
+-- RUpdate -> T.intercalate "/" [rRoot, showT unDBId]
+-- RDestroy -> T.intercalate "/" [rRoot, showT unDBId, "destroy"]
+-- x -> error $ "Unimplemented crudpath " ++ show x
--------------------------------------------------------------------------------
-itemActionPath Resource{..} t DBId{..} = T.intercalate "/" [rRoot, showT unDBId, t]
+------------------------------------------------------------------------------
+itemActionPath Resource{..} t DBId{..} =
+ T.intercalate "/" [rRoot, showT unDBId, t]
--------------------------------------------------------------------------------
+------------------------------------------------------------------------------
indexPath :: Resource b v a -> Text
indexPath r = rRoot r
--------------------------------------------------------------------------------
+------------------------------------------------------------------------------
createPath :: Resource b v a -> Text
createPath r = rRoot r
--------------------------------------------------------------------------------
+------------------------------------------------------------------------------
+newPath :: Resource b v a -> Text
+newPath r = T.intercalate "/" [rRoot r, "new"]
+
+
+------------------------------------------------------------------------------
rootPath :: Resource b v a -> Text
rootPath = indexPath
--------------------------------------------------------------------------------
+------------------------------------------------------------------------------
editPath :: Resource b v a -> DBId -> Text
-editPath r dbid = crudPath r REdit dbid
+editPath r (DBId _id) = T.intercalate "/" [rRoot r, showT _id, "edit"]
--------------------------------------------------------------------------------
+------------------------------------------------------------------------------
showPath :: Resource b v a -> DBId -> Text
-showPath r dbid = crudPath r RShow dbid
+showPath r (DBId _id) = T.intercalate "/" [rRoot r, showT _id]
--------------------------------------------------------------------------------
+------------------------------------------------------------------------------
updatePath :: Resource b v a -> DBId -> Text
-updatePath r dbid = crudPath r RUpdate dbid
+updatePath r (DBId _id) = T.intercalate "/" [rRoot r, showT _id]
--------------------------------------------------------------------------------
+------------------------------------------------------------------------------
destroyPath :: Resource b v a -> DBId -> Text
-destroyPath r dbid = crudPath r RDestroy dbid
-
-
--------------------------------------------------------------------------------
-newPath :: Resource b v a -> DBId -> Text
-newPath r dbid = crudPath r RNew dbid
-
+destroyPath r (DBId _id) = T.intercalate "/" [rRoot r, showT _id, "destroy"]
-
--------------------------------------------------------------------------------
+------------------------------------------------------------------------------
resourceSplices :: Resource b v a -> [(Text, SnapletSplice b v)]
resourceSplices r@Resource{..} =
- [ (T.concat [rName, "NewPath"], liftHeist . textSplice $ newPath r def)
+ [ (T.concat [rName, "NewPath"], liftHeist . textSplice $ newPath r)
, (T.concat [rName, "IndexPath"], liftHeist . textSplice $ indexPath r)
, (T.concat [rName, "CreatePath"], liftHeist . textSplice $ createPath r)
, (T.concat [rName, "Path"], liftHeist . textSplice $ rootPath r)
+
+ -- This splice is designed to be used in create and update forms to specify
+ -- the correct action URL.
+ , ("RESTFormAction", getFormAction)
]
+setFormAction a = localRequest f
+ where
+ f req = req { rqParams = M.insert "RESTFormAction" [T.encodeUtf8 a]
+ (rqParams req) }
+
+getFormAction = do
+ p <- liftHandler $ getParam "RESTFormAction"
+ maybe (return []) (liftHeist . textSplice . T.decodeUtf8) p
--------------------------------------------------------------------------------
+
+------------------------------------------------------------------------------
itemSplices :: Monad m => Resource b v a -> DBId -> [(Text, Splice m)]
itemSplices r@Resource{..} dbid =
map (mkItemActionSplice r dbid . fst) rItemActions ++
[ (T.concat [rName, "ItemEditPath"], textSplice $ editPath r dbid)
, (T.concat [rName, "ItemShowPath"], textSplice $ showPath r dbid)
, (T.concat [rName, "ItemUpdatePath"], textSplice $ updatePath r dbid)
, (T.concat [rName, "ItemDestroyPath"], textSplice $ destroyPath r dbid)
- , (T.concat [rName, "ItemNewPath"], textSplice $ newPath r dbid)
+ , (T.concat [rName, "ItemNewPath"], textSplice $ newPath r)
, (T.concat [rName, "ItemIndexPath"], textSplice $ indexPath r)
, (T.concat [rName, "ItemCreatePath"], textSplice $ createPath r)
]
--------------------------------------------------------------------------------
+------------------------------------------------------------------------------
itemSplices':: Resource b v a -> DBId -> [(Text, SnapletSplice b v)]
itemSplices' r = map (second liftHeist) . itemSplices r
--------------------------------------------------------------------------------
-mkItemActionSplice
- :: Monad m => Resource b v a -> DBId -> Text -> (Text, Splice m)
+------------------------------------------------------------------------------
+mkItemActionSplice :: Monad m
+ => Resource b v a -> DBId -> Text -> (Text, Splice m)
mkItemActionSplice r@Resource{..} dbid t =
- (T.concat [rName, "Item", cap t, "Path"], textSplice $ itemActionPath r t dbid)
+ ( T.concat [rName, "Item", cap t, "Path"]
+ , textSplice $ itemActionPath r t dbid)
--------------------------------------------------------------------------------
+------------------------------------------------------------------------------
-- | Redirect to given item's default show page
redirToItem :: MonadSnap m => Resource b v a -> DBId -> m a
redirToItem r dbid = redirect . T.encodeUtf8 $ showPath r dbid
--------------------------------------------------------------------------------
+------------------------------------------------------------------------------
showT :: Show a => a -> Text
showT = T.pack . show
--------------------------------------------------------------------------------
+------------------------------------------------------------------------------
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
+
+

0 comments on commit d85b361

Please sign in to comment.