yesod/Web/Restful/Response.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeSynonymInstances #-} -- FIXME remove
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE DeriveDataTypeable #-}
---------------------------------------------------------
--
-- Module        : Web.Restful.Response
-- Copyright     : Michael Snoyman
-- License       : BSD3
--
-- Maintainer    : Michael Snoyman <michael@snoyman.com>
-- Stability     : Stable
-- Portability   : portable
--
-- Generating responses.
--
---------------------------------------------------------
module Web.Restful.Response
    ( Response (..)
      -- * Representations
    , RepT
    , chooseRep
    , HasReps (..)
    , ContentType
      -- * Content
    , Content
    , ToContent (..)
    , runContent
    , lbsContent
    , translateContent
      -- * Abnormal responses
    , ErrorResult (..)
    , getHeaders
    , getStatus
      -- * Header
    , Header (..)
    , toPair
      -- * Generic responses
    , genResponse
    , htmlResponse
    , objectResponse
      -- * Tests
    , testSuite
    ) where

import Data.Time.Clock
import Data.Object
import Data.Object.Raw
import Data.Object.Translate
import Data.Object.Instances
import qualified Data.ByteString.Lazy as LBS
import Data.ByteString.Class
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Encoding as LTE

import Web.Encodings (formatW3)

import Test.Framework (testGroup, Test)

import Data.Generics
import Control.Exception (Exception)
import Data.Maybe (fromJust)

data Response = Response Int [Header] ContentType Content

type ContentType = String

data Content = ByteString LBS.ByteString
             | Text LT.Text
             | TransText ([Language] -> LT.Text)

runContent :: [Language] -> Content -> LBS.ByteString
runContent _ (ByteString lbs) = lbs
runContent _ (Text lt) = LTE.encodeUtf8 lt
runContent ls (TransText t) = LTE.encodeUtf8 $ t ls

class ToContent a where
    toContent :: a -> Content
instance ToContent LBS.ByteString where
    toContent = ByteString
instance ToContent String where
    toContent = Text . LT.pack
instance ToContent ([Language] -> String) where
    toContent f = TransText $ LT.pack . f
instance ToContent Translator where
    toContent = TransText

lbsContent :: LazyByteString lbs => lbs -> Content
lbsContent = ByteString . toLazyByteString

translateContent :: CanTranslate t => t -> Content
translateContent t = toContent $ translate t

type RepT m = (ContentType, m Content)

chooseRep :: Monad m
          => [ContentType]
          -> [RepT m]
          -> RepT m
chooseRep cs rs
  | null rs = error "All reps must have at least one representation" -- FIXME
  | otherwise = do
    let availCs = map fst rs
    case filter (`elem` availCs) cs of
        [] -> head rs
        [ctype] -> (ctype, fromJust $ lookup ctype rs) -- FIXME
        _ -> error "Overlapping representations" -- FIXME just take the first?

-- | Something which can be represented as multiple content types.
-- Each content type is called a representation of the data.
class Monad m => HasReps a m where
    -- | Provide an ordered list of possible representations, depending on
    -- content type. If the user asked for a specific response type (like
    -- text/html), then that will get priority. If not, then the first
    -- element in this list will be used.
    reps :: a -> [RepT m]

-- | Abnormal return codes.
data ErrorResult =
    Redirect String
    | NotFound
    | InternalError String
    | InvalidArgs [(String, String)]
    | PermissionDenied
    deriving (Show, Typeable)
instance Exception ErrorResult

getStatus :: ErrorResult -> Int
getStatus (Redirect _) = 303
getStatus NotFound = 404
getStatus (InternalError _) = 500
getStatus (InvalidArgs _) = 400
getStatus PermissionDenied = 403

getHeaders :: ErrorResult -> [Header]
getHeaders (Redirect s) = [Header "Location" s]
getHeaders _ = []

----- header stuff
-- | Headers to be added to a 'Result'.
data Header =
    AddCookie Int String String
    | DeleteCookie String
    | Header String String

-- | Convert Header to a key/value pair.
toPair :: Header -> IO (String, String)
toPair (AddCookie minutes key value) = do
    now <- getCurrentTime
    let expires = addUTCTime (fromIntegral $ minutes * 60) now
    return ("Set-Cookie", key ++ "=" ++ value ++"; path=/; expires="
                              ++ formatW3 expires)
toPair (DeleteCookie key) = return
    ("Set-Cookie",
     key ++ "=; path=/; expires=Thu, 01-Jan-1970 00:00:00 GMT")
toPair (Header key value) = return (key, value)

------ Generic responses
-- FIXME move these to Handler?
-- | Return a response with an arbitrary content type.
genResponse :: (Monad m, LazyByteString lbs)
            => ContentType
            -> lbs
            -> [RepT m]
genResponse ct lbs = [(ct, return $ lbsContent lbs)]

-- | Return a response with a text/html content type.
htmlResponse :: (Monad m, LazyByteString lbs) => lbs -> [RepT m]
htmlResponse = genResponse "text/html"

-- | Return a response from an Object. FIXME use TextObject
objectResponse :: (Monad m, ToObject o Raw Raw) => o -> [RepT m]
objectResponse = reps . toRawObject

-- HasReps instances
instance Monad m => HasReps () m where
    reps _ = [("text/plain", return $ lbsContent "")]
instance Monad m => HasReps RawObject m where -- FIXME TextObject
    reps o =
        [ ("text/html", return $ lbsContent $ unHtml $ safeFromObject o)
        , ("application/json", return $ lbsContent $ unJson $ safeFromObject o)
        , ("text/yaml", return $ lbsContent $ unYaml $ safeFromObject o)
        ]

{- FIXME
instance HasReps (Reps m) where
    reps = id
-}

----- Testing
testSuite :: Test
testSuite = testGroup "Web.Restful.Response"
    [
    ]