{-# 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