module Snap.Snaplet.Rest.Resource.Media
(
Media (..)
, newMedia
, newResponseMedia
, newRequestMedia
, newIntermediateMedia
, MediaSetter
, fromResource
, toResource
, toDiff
, toEither
, fromResourceList
, toResourceList
, json
, jsonFromInstances
, xml
, xhtml
, html
, form
, multipart
) where
import qualified Blaze.ByteString.Builder as BB
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.UTF8 as BS
import qualified Text.XmlHtml as Xml
import Control.Lens
import Control.Monad
import Data.Aeson hiding (json)
import Data.ByteString (ByteString)
import Network.HTTP.Media (MediaType)
import Snap.Core
import Text.XmlHtml (Document)
data Media res m diff int = Media
{ _fromResource :: Maybe (res -> m int)
, _toResource :: Maybe (int -> m (Maybe res))
, _toDiff :: Maybe (int -> m (Maybe diff))
, _fromResourceList :: Maybe ([res] -> m int)
, _toResourceList :: Maybe (int -> m (Maybe [res]))
, responseMedia :: Maybe ([MediaType], int -> m ByteString)
, requestMedia :: Maybe ([MediaType], ByteString -> m (Maybe int))
}
class Intermediate int where
defaultFrom :: MonadSnap m => int -> m ByteString
defaultTo :: MonadSnap m => ByteString -> m (Maybe int)
instance Intermediate ByteString where
defaultFrom = return
defaultTo = return . Just
instance Intermediate String where
defaultFrom = return . BS.fromString
defaultTo = return . Just . BS.toString
newMedia
:: (Intermediate int, MonadSnap m) => [MediaType] -> [MediaType]
-> Media res m diff int
newMedia = newIntermediateMedia defaultFrom defaultTo
newResponseMedia
:: (int -> m ByteString) -> [MediaType] -> Media res m diff int
newResponseMedia a b =
Media Nothing Nothing Nothing Nothing Nothing (notEmpty b a) Nothing
newRequestMedia
:: (ByteString -> m (Maybe int)) -> [MediaType]
-> Media res m diff int
newRequestMedia a b =
Media Nothing Nothing Nothing Nothing Nothing Nothing (notEmpty b a)
newIntermediateMedia
:: (int -> m ByteString) -> (ByteString -> m (Maybe int))
-> [MediaType] -> [MediaType] -> Media res m diff int
newIntermediateMedia a b x y = Media
Nothing Nothing Nothing Nothing Nothing (notEmpty x a) (notEmpty y b)
notEmpty :: [a] -> f -> Maybe ([a], f)
notEmpty l f = guard (not $ null l) >> Just (l, f)
type MediaSetter res m diff int f a = Setter
(Media res m diff int) (Media res m diff int) (f a) a
fromResource :: MediaSetter res m diff int Maybe (res -> m int)
fromResource f m = f (_fromResource m) <&> \g -> m { _fromResource = Just g }
toResource :: MediaSetter res m diff int Maybe (int -> m (Maybe res))
toResource f m = f (_toResource m) <&> \g -> m { _toResource = Just g }
toDiff :: MediaSetter res m diff int Maybe (int -> m (Maybe diff))
toDiff f m = f (_toDiff m) <&> \g -> m { _toDiff = Just g }
toEither :: MediaSetter res m res int Both (int -> m (Maybe res))
toEither f m = f (_toResource m, _toDiff m) <&> \g -> m
{ _toResource = Just g
, _toDiff = Just g
}
type Both a = (Maybe a, Maybe a)
fromResourceList :: MediaSetter res m diff int Maybe ([res] -> m int)
fromResourceList f m =
f (_fromResourceList m) <&> \g -> m { _fromResourceList = Just g }
toResourceList :: MediaSetter res m diff int Maybe (int -> m (Maybe [res]))
toResourceList f m =
f (_toResourceList m) <&> \g -> m { _toResourceList = Just g }
json :: Monad m => Media res m diff Value
json = newIntermediateMedia
(return . LBS.toStrict . encode) (return . decodeStrict)
["application/json; charset=utf-8"] ["application/json"]
jsonFromInstances
:: (Monad m, ToJSON res, FromJSON res, FromJSON diff)
=> Media res m diff Value
jsonFromInstances = Media
(Just (return . toJSON))
(Just (return . resultToMaybe . fromJSON))
(Just (return . resultToMaybe . fromJSON))
(Just (return . toJSON))
(Just (return . resultToMaybe . fromJSON))
(Just (["application/json; charset=utf-8"],
return . LBS.toStrict . encode))
(Just (["application/json"], return . decode . LBS.fromStrict))
resultToMaybe :: Result a -> Maybe a
resultToMaybe (Error _) = Nothing
resultToMaybe (Success a) = Just a
xml :: Monad m => Media res m diff Document
xml = newIntermediateMedia
(return . BB.toByteString . Xml.render)
(return . either (const Nothing) Just . Xml.parseXML "")
["application/xml; charset=utf-8"] ["application/xml"]
xhtml :: MonadSnap m => Media res m diff ByteString
xhtml = newMedia
["application/xhtml+xml; charset=utf-8", "text/html; charset=utf-8"] []
html :: MonadSnap m => Media res m diff ByteString
html = newMedia ["text/html; charset=utf-8"] []
form :: MonadSnap m => Media res m diff Params
form = newRequestMedia (const $ fmap Just getParams)
["application/x-www-form-urlencoded"]
multipart :: MonadSnap m => Media res m diff ByteString
multipart = newMedia [] ["multipart/form-data"]