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
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)
data CRUD = RIndex
| RShow
| RNew
| REdit
| RCreate
| RUpdate
| RDestroy
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
data Resource = Resource {
rName :: Text
, rRoot :: Text
, rResourceEndpoints :: [Text]
, rItemEndpoints :: [Text]
}
instance Default Resource where
def = Resource "items" "/items" [] []
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
unitLens :: Lens' b ()
unitLens = lens (const ()) (\a () -> a)
addResource :: HasHeist b
=> Resource
-> [(CRUD, Handler b v ())]
-> [(Text, Handler b v ())]
-> [(Text, Handler b v ())]
-> Snaplet (Heist b)
-> 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
addResourceRelative :: HasHeist b
=> Resource
-> [(CRUD, Handler b v ())]
-> [(Text, Handler b v ())]
-> [(Text, Handler b v ())]
-> Snaplet (Heist b)
-> Initializer b v ()
addResourceRelative res rHandlers rResourceActions rItemActions h = do
addRoutes $ [(":id/:action", restfulHeistServe res)]
addResource' resourceRoutesRelative res rHandlers rResourceActions rItemActions h
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
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 }
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)
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
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)
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]
itemActionPath :: Resource -> Text -> DBId -> Text
itemActionPath Resource{..} t DBId{..} =
mkPath [rRoot, showT unDBId, t]
indexPath :: Resource -> Text
indexPath r = rRoot r
createPath :: Resource -> Text
createPath r = rRoot r
newPath :: Resource -> Text
newPath r = mkPath [rRoot r, "new"]
rootPath :: Resource -> Text
rootPath = indexPath
editPath :: Resource -> DBId -> Text
editPath r (DBId _id) = mkPath [rRoot r, showT _id, "edit"]
showPath :: Resource -> DBId -> Text
showPath r (DBId _id) = mkPath [rRoot r, showT _id]
updatePath :: Resource -> DBId -> Text
updatePath r (DBId _id) = mkPath [rRoot r, showT _id]
destroyPath :: Resource -> DBId -> Text
destroyPath r (DBId _id) = mkPath [rRoot r, showT _id, "destroy"]
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) }
getFormAction :: MonadSnap m => HeistT n m [X.Node]
getFormAction = do
p <- lift $ getParam "RESTFormAction"
maybe (return []) (I.textSplice . T.decodeUtf8) p
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)
]
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)
]
resourceCSplices :: MonadSnap m => Resource -> [(Text, C.Splice m)]
resourceCSplices r = C.mapSnd (C.runNodeList =<<) $ resourceSplices r
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
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)
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)
mkItemActionCSplice :: Resource -> Text -> (Text, DBId -> Text)
mkItemActionCSplice r@Resource{..} t =
( T.concat [rName, "Item", cap t, "Path"]
, itemActionPath r t)
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
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"
simpleDateFormlet :: (Monad m)
=> Maybe Day -> Form Text m Day
simpleDateFormlet d = validate validDate $
text (dayText <$> d)
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