diff --git a/Data/Object/Translate.hs b/Data/Object/Translate.hs new file mode 100644 index 00000000..70af27dc --- /dev/null +++ b/Data/Object/Translate.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +--------------------------------------------------------- +-- +-- Module : Data.Object.Translate +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Stable +-- Portability : portable +-- +-- Objects which can be translated into different languages. +--------------------------------------------------------- +module Data.Object.Translate + ( -- * Types + Language + , TranslatedString + , Translator + , TranslateObject + , TranslateKeyObject + -- * Type classes + , CanTranslate (..) + -- * Utilities for objects + , translateObject + , translateKeyObject + -- * Specialized functions + , toTranslateObject + , fromTranslateObject + ) where + +import Data.Maybe (fromMaybe) +import Data.Object +import Data.Attempt +import Data.Object.Text + +-- | Should usually be the well established I18N translation code. Examples +-- include en, en_US, es, and so on. If you use these common codes, you will +-- have easy interop with other systems. +type Language = String +type TranslatedString = Text + +-- | Given a list of destination languages (ordered by preference), generate +-- a translated string. Must return some value. +type Translator = [Language] -> TranslatedString + +-- | Usually you do not need to translate both keys and values, so this should +-- be the more common type. +type TranslateObject = Object Text Translator + +-- | For the occassions when you really need to translate everything. +type TranslateKeyObject = Object Translator Translator + +-- | Anything which can be translated into a different language. +-- +-- Minimal complete definition: translate or (tryTranslate and +-- defaultTranslate). +class CanTranslate a where + translate :: a -> Translator + translate a [] = defaultTranslate a + translate a (lang:langs) = + fromMaybe (translate a langs) $ tryTranslate a lang + + tryTranslate :: a -> Language -> Maybe TranslatedString + tryTranslate a = Just . translate a . return + + defaultTranslate :: a -> TranslatedString + defaultTranslate a = translate a [] + +instance CanTranslate Text where + translate = const + +-- | Generate a 'TextObject' with the translation of the +-- original based on the language list supplied. +translateObject :: [Language] + -> TranslateObject + -> TextObject +translateObject langs = fmap ($ langs) + +-- | Same as 'translateObject', but translate the keys as well as the values. +translateKeyObject :: [Language] + -> TranslateKeyObject + -> TextObject +translateKeyObject langs = mapKeysValues ($ langs) ($ langs) + +-- | 'toObject' specialized for 'TranslateObject's +toTranslateObject :: ToObject a TranslatedString Translator + => a -> TranslateObject +toTranslateObject = toObject + +-- | 'fromObject' specialized for 'TranslateObject's +fromTranslateObject :: FromObject a TranslatedString Translator + => TranslateObject + -> Attempt a +fromTranslateObject = fromObject diff --git a/Hack/Middleware/CleanPath.hs b/Hack/Middleware/CleanPath.hs new file mode 100644 index 00000000..71c6973e --- /dev/null +++ b/Hack/Middleware/CleanPath.hs @@ -0,0 +1,61 @@ +module Hack.Middleware.CleanPath (cleanPath, splitPath) where + +import Hack +import qualified Data.ByteString.Lazy as BS +import Data.List +import Web.Encodings +import Data.List.Split + +-- | Performs redirects as per 'splitPath'. +cleanPath :: Middleware +cleanPath app env = + case splitPath $ pathInfo env of + Left p -> do + -- include the query string if there + let suffix = + case queryString env of + "" -> "" + q@('?':_) -> q + q -> '?' : q + return $! Response 303 [("Location", p ++ suffix)] BS.empty + Right _ -> app env + +-- | Given a certain requested path, return either a corrected path +-- to redirect to or the tokenized path. +-- +-- This code corrects for the following issues: +-- +-- * It is missing a trailing slash, and there is no period after the +-- last slash. +-- +-- * There are any doubled slashes. +splitPath :: String -> Either String [String] +splitPath s = + let corrected = ats $ rds s + in if corrected == s + then Right $ map decodeUrl $ filter (\l -> length l /= 0) + $ splitOneOf "/" s + else Left corrected + +-- | Remove double slashes +rds :: String -> String +rds [] = [] +rds [x] = [x] +rds (a:b:c) + | a == '/' && b == '/' = rds (b:c) + | otherwise = a : rds (b:c) + +-- | Add a trailing slash if it is missing. Empty string is left alone. +ats :: String -> String +ats [] = [] +ats s = + if last s == '/' || dbs (reverse s) + then s + else s ++ "/" + +-- | Is there a period before a slash here? +dbs :: String -> Bool +dbs ('/':_) = False +dbs ('.':_) = True +dbs (_:x) = dbs x +dbs [] = False diff --git a/Hack/Middleware/ClientSession.hs b/Hack/Middleware/ClientSession.hs new file mode 100644 index 00000000..e58a4e99 --- /dev/null +++ b/Hack/Middleware/ClientSession.hs @@ -0,0 +1,118 @@ +module Hack.Middleware.ClientSession + ( clientsession + -- * Generating keys + , Word256 + , defaultKeyFile + , getKey + , getDefaultKey + ) where + +import Prelude hiding (exp) +import Hack +import Web.Encodings +import Data.List (partition, intercalate) +import Data.Function.Predicate (is, isn't, equals) +import Data.Maybe (fromMaybe) +import Web.ClientSession +import Data.Time.Clock (getCurrentTime, UTCTime, addUTCTime) +import Data.Time.LocalTime () -- Show instance of UTCTime +import Data.Time.Format (formatTime) -- Read instance of UTCTime +import System.Locale (defaultTimeLocale) +import Control.Monad (guard) + +-- | Automatic encrypting and decrypting of client session data. +-- +-- Using the clientsession package, this middleware handles automatic +-- encryption, decryption, checking, expiration and renewal of whichever +-- cookies you ask it to. For example, if you tell it to deal with the +-- cookie \"IDENTIFIER\", it will do the following: +-- +-- * When you specify an \"IDENTIFIER\" value in your 'Response', it will +-- encrypt the value, along with the session expiration date and the +-- REMOTE_HOST of the user. It will then be set as a cookie on the client. +-- +-- * When there is an incoming \"IDENTIFIER\" cookie from the user, it will +-- decrypt it and check both the expiration date and the REMOTE_HOST. If +-- everything matches up, it will set the \"IDENTIFIER\" value in +-- 'hackHeaders'. +-- +-- * If the client sent an \"IDENTIFIER\" and the application does not set +-- a new value, this will reset the cookie to a new expiration date. This +-- way, you do not have sessions timing out every 20 minutes. +-- +-- As far as security: clientsesion itself handles hashing and encrypting +-- the data to make sure that the user can neither see not tamper with it. +clientsession :: [String] -- ^ list of cookies to intercept + -> Word256 -- ^ encryption key + -> Middleware +clientsession cnames key app env = do + let initCookiesRaw :: String + initCookiesRaw = fromMaybe "" $ lookup "Cookie" $ http env + nonCookies :: [(String, String)] + nonCookies = filter (fst `isn't` (== "Cookie")) $ http env + initCookies :: [(String, String)] + initCookies = decodeCookies initCookiesRaw + cookies, interceptCookies :: [(String, String)] + (interceptCookies, cookies) = partition (fst `is` (`elem` cnames)) + initCookies + cookiesRaw :: String + cookiesRaw = intercalate "; " $ map (\(k, v) -> k ++ "=" ++ v) + cookies + remoteHost :: String + remoteHost = fromMaybe "" $ lookup "REMOTE_HOST" $ http env + now <- getCurrentTime + let convertedCookies = + takeJusts $ + map (decodeCookie key now remoteHost) interceptCookies + let env' = env { http = ("Cookie", cookiesRaw) + : filter (fst `equals` "Cookie") (http env) + ++ nonCookies + , hackHeaders = hackHeaders env ++ convertedCookies + } + res <- app env' + let (interceptHeaders, headers') = partition (fst `is` (`elem` cnames)) + $ headers res + let twentyMinutes :: Int + twentyMinutes = 20 * 60 + let exp = fromIntegral twentyMinutes `addUTCTime` now + let formattedExp = formatTime defaultTimeLocale "%a, %d-%b-%Y %X %Z" exp + let oldCookies = filter (\(k, _) -> not $ k `elem` map fst interceptHeaders) convertedCookies + let newCookies = map (setCookie key exp formattedExp remoteHost) $ + oldCookies ++ interceptHeaders + let res' = res { headers = newCookies ++ headers' } + return res' + +takeJusts :: [Maybe a] -> [a] +takeJusts [] = [] +takeJusts (Just x:rest) = x : takeJusts rest +takeJusts (Nothing:rest) = takeJusts rest + +setCookie :: Word256 + -> UTCTime -- ^ expiration time + -> String -- ^ formatted expiration time + -> String -- ^ remote host + -> (String, String) -> (String, String) +setCookie key exp fexp rhost (cname, cval) = + ("Set-Cookie", cname ++ "=" ++ val ++ "; path=/; expires=" ++ fexp) + where + val = encrypt key $ show $ Cookie exp rhost cval + +data Cookie = Cookie UTCTime String String deriving (Show, Read) +decodeCookie :: Word256 -- ^ key + -> UTCTime -- ^ current time + -> String -- ^ remote host field + -> (String, String) -- ^ cookie pair + -> Maybe (String, String) +decodeCookie key now rhost (cname, encrypted) = do + decrypted <- decrypt key encrypted + (Cookie exp rhost' val) <- mread decrypted + guard $ exp > now + guard $ rhost' == rhost + guard $ val /= "" + return (cname, val) + +mread :: (Monad m, Read a) => String -> m a +mread s = + case reads s of + [] -> fail $ "Reading of " ++ s ++ " failed" + ((x, _):_) -> return x diff --git a/Hack/Middleware/Gzip.hs b/Hack/Middleware/Gzip.hs new file mode 100644 index 00000000..3da4d1a8 --- /dev/null +++ b/Hack/Middleware/Gzip.hs @@ -0,0 +1,44 @@ +--------------------------------------------------------- +-- | +-- Module : Hack.Middleware.Gzip +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Unstable +-- Portability : portable +-- +-- Automatic gzip compression of responses. +-- +--------------------------------------------------------- +module Hack.Middleware.Gzip (gzip) where + +import Hack +import Codec.Compression.GZip (compress) +import Data.Maybe (fromMaybe) +import Data.List.Split (splitOneOf) + +-- | Use gzip to compress the body of the response. +-- +-- Analyzes the \"Accept-Encoding\" header from the client to determine +-- if gzip is supported. +-- +-- Possible future enhancements: +-- +-- * Only compress if the response is above a certain size. +-- +-- * Add Content-Length. +-- +-- * I read somewhere that \"the beast\" (MSIE) can\'t support compression +-- for Javascript files.. +gzip :: Middleware +gzip app env = do + res <- app env + let enc = fromMaybe [] $ splitOneOf "," `fmap` lookup "Accept-Encoding" + (http env) + if "gzip" `elem` enc + then return res + { body = compress $ body res + , headers = ("Content-Encoding", "gzip") : headers res + } + else return res diff --git a/Hack/Middleware/Jsonp.hs b/Hack/Middleware/Jsonp.hs new file mode 100644 index 00000000..bf8d8803 --- /dev/null +++ b/Hack/Middleware/Jsonp.hs @@ -0,0 +1,66 @@ +--------------------------------------------------------- +-- | +-- Module : Hack.Middleware.Jsonp +-- Copyright : Michael Snoyman +-- License : BSD3 +-- +-- Maintainer : Michael Snoyman +-- Stability : Unstable +-- Portability : portable +-- +-- Automatic wrapping of JSON responses to convert into JSONP. +-- +--------------------------------------------------------- +module Hack.Middleware.Jsonp (jsonp) where + +import Hack +import Web.Encodings (decodeUrlPairs) +import qualified Data.ByteString.Lazy.Char8 as B8 +import Data.Maybe (fromMaybe) +import Data.List (isInfixOf) + +-- | Wrap json responses in a jsonp callback. +-- +-- Basically, if the user requested a \"text\/javascript\" and supplied a +-- \"callback\" GET parameter, ask the application for an +-- \"application/json\" response, then convern that into a JSONP response, +-- having a content type of \"text\/javascript\" and calling the specified +-- callback function. +jsonp :: Middleware +jsonp app env = do + let accept = fromMaybe "" $ lookup "Accept" $ http env + let gets = decodeUrlPairs $ queryString env + let callback :: Maybe String + callback = + if "text/javascript" `isInfixOf` accept + then lookup "callback" gets + else Nothing + let env' = + case callback of + Nothing -> env + Just _ -> env + { http = changeVal "Accept" + "application/json" + $ http env + } + res <- app env' + let ctype = fromMaybe "" $ lookup "Content-Type" $ headers res + case callback of + Nothing -> return res + Just c -> + case ctype of + "application/json" -> return $ res + { headers = changeVal "Content-Type" + "text/javascript" + $ headers res + , body = B8.concat + [ B8.pack c -- NOTE uses Latin-1 encoding. + , B8.singleton '(' + , body res + , B8.singleton ')' + ] + } + _ -> return res + +changeVal :: String -> String -> [(String, String)] -> [(String, String)] +changeVal key val old = (key, val) : filter (\(k, _) -> k /= key) old diff --git a/Web/Restful/Application.hs b/Web/Restful/Application.hs index ec69768f..98271329 100644 --- a/Web/Restful/Application.hs +++ b/Web/Restful/Application.hs @@ -43,6 +43,9 @@ import Web.Restful.Definitions import Web.Restful.Constants import Web.Restful.Resource +import Data.Convertible +import Control.Arrow ((***)) + -- | A data type that can be turned into a Hack application. class ResourceName a => RestfulApp a where -- | The encryption key to be used for encrypting client sessions. @@ -160,9 +163,15 @@ envToRawRequest urlParams' env = gets' = decodeUrlPairs $ Hack.queryString env :: [(String, String)] clength = tryLookup "0" "Content-Length" $ Hack.http env ctype = tryLookup "" "Content-Type" $ Hack.http env - (posts, files) = parsePost ctype clength + (posts, files) = map (convertSuccess *** convertSuccess) *** + map (convertSuccess *** convertFileInfo) + $ parsePost ctype clength $ Hack.hackInput env rawCookie = tryLookup "" "Cookie" $ Hack.http env cookies' = decodeCookies rawCookie :: [(String, String)] langs = ["en"] -- FIXME in RawRequest rawPieces urlParams' gets' posts cookies' files env langs + +convertFileInfo :: ConvertSuccess a b => FileInfo a c -> FileInfo b c +convertFileInfo (FileInfo a b c) = + FileInfo (convertSuccess a) (convertSuccess b) c diff --git a/Web/Restful/Response/AtomFeed.hs b/Web/Restful/Helpers/AtomFeed.hs similarity index 98% rename from Web/Restful/Response/AtomFeed.hs rename to Web/Restful/Helpers/AtomFeed.hs index 37e6e652..727da65e 100644 --- a/Web/Restful/Response/AtomFeed.hs +++ b/Web/Restful/Helpers/AtomFeed.hs @@ -14,7 +14,7 @@ -- --------------------------------------------------------- -module Web.Restful.Response.AtomFeed +module Web.Restful.Helpers.AtomFeed ( AtomFeed (..) , AtomFeedEntry (..) ) where diff --git a/Web/Restful/Response/Sitemap.hs b/Web/Restful/Helpers/Sitemap.hs similarity index 98% rename from Web/Restful/Response/Sitemap.hs rename to Web/Restful/Helpers/Sitemap.hs index de9d510b..da291897 100644 --- a/Web/Restful/Response/Sitemap.hs +++ b/Web/Restful/Helpers/Sitemap.hs @@ -14,7 +14,7 @@ -- --------------------------------------------------------- -module Web.Restful.Response.Sitemap +module Web.Restful.Helpers.Sitemap ( sitemap , robots , SitemapUrl (..) diff --git a/Web/Restful/Request.hs b/Web/Restful/Request.hs index f89b103f..870d1b27 100644 --- a/Web/Restful/Request.hs +++ b/Web/Restful/Request.hs @@ -56,6 +56,7 @@ import Web.Encodings import Data.Time.Calendar (Day, fromGregorian) import Data.Char (isDigit) import Data.Object.Translate (Language) +import qualified Data.ByteString.Lazy as BL -- $param_overview -- In Restful, all of the underlying parameter values are strings. They can @@ -231,7 +232,7 @@ data RawRequest = RawRequest , rawGetParams :: [(ParamName, ParamValue)] , rawPostParams :: [(ParamName, ParamValue)] , rawCookies :: [(ParamName, ParamValue)] - , rawFiles :: [(ParamName, FileInfo)] + , rawFiles :: [(ParamName, FileInfo String BL.ByteString)] , rawEnv :: Hack.Env , rawLanguages :: [Language] } diff --git a/restful.cabal b/restful.cabal index a248a91b..17d71cc6 100644 --- a/restful.cabal +++ b/restful.cabal @@ -1,5 +1,5 @@ name: restful -version: 0.1.11 +version: 0.1.12 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -21,32 +21,27 @@ library else Buildable: True build-depends: base >= 4 && < 5, - old-locale >= 1.0.0.1, - time >= 1.1.3, - hack-middleware-clientsession, - hack-middleware-jsonp >= 0.0.2, - hack-middleware-cleanpath >= 0.0.1, - hack-middleware-gzip, - hack-handler-cgi >= 0.0.2, + old-locale >= 1.0.0.1 && < 1.1, + time >= 1.1.3 && < 1.2, hack >= 2009.5.19, - split >= 0.1.1, - authenticate >= 0.2.1, - data-default >= 0.2, - predicates >= 0.1, - bytestring >= 0.9.1.4, - bytestring-class, - web-encodings >= 0.0.1, - data-object >= 0.2.0, - data-object-translate, - yaml >= 0.2.0, - enumerable >= 0.0.3, - directory >= 1, - transformers >= 0.1.4.0, - monads-fd >= 0.0.0.1, - attempt >= 0.0.2, + split >= 0.1.1 && < 0.2, + authenticate >= 0.2.1 && < 0.3, + data-default >= 0.2 && < 0.3, + predicates >= 0.1 && < 0.2, + bytestring >= 0.9.1.4 && < 0.10, + web-encodings >= 0.2.0 && < 0.3, + data-object >= 0.2.0 && < 0.3, + yaml >= 0.2.0 && < 0.3, + enumerable >= 0.0.3 && < 0.1, + directory >= 1 && < 1.1, + transformers >= 0.1.4.0 && < 0.2, + monads-fd >= 0.0.0.1 && < 0.1, + attempt >= 0.0.2 && < 0.1, syb, - text >= 0.5, - convertible >= 1.2.0 + text >= 0.5 && < 0.6, + convertible >= 1.2.0 && < 1.3, + clientsession >= 0.0.1 && < 0.1, + zlib >= 0.5.2.0 && < 0.6 exposed-modules: Web.Restful, Web.Restful.Constants, Web.Restful.Request, @@ -57,11 +52,16 @@ library Web.Restful.Application, Web.Restful.Resource, Data.Object.Instances, + Data.Object.Translate, Hack.Middleware.MethodOverride, + Hack.Middleware.ClientSession, + Hack.Middleware.Jsonp, + Hack.Middleware.CleanPath, + Hack.Middleware.Gzip, Web.Restful.Helpers.Auth, Web.Restful.Helpers.Static, - Web.Restful.Response.AtomFeed, - Web.Restful.Response.Sitemap + Web.Restful.Helpers.AtomFeed, + Web.Restful.Helpers.Sitemap ghc-options: -Wall -Werror executable runtests