Integrated some external packages; web-encodings 0.2.0

Data/Object/Translate.hs

@@ -0,0 +1,95 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleContexts #-}
+---------------------------------------------------------
+--
+-- Module        : Data.Object.Translate
+-- Copyright     : Michael Snoyman
+-- License       : BSD3
+--
+-- Maintainer    : Michael Snoyman <michael@snoyman.com>
+-- 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

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

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

Hack/Middleware/Gzip.hs

@@ -0,0 +1,44 @@
+---------------------------------------------------------
+-- |
+-- Module        : Hack.Middleware.Gzip
+-- Copyright     : Michael Snoyman
+-- License       : BSD3
+--
+-- Maintainer    : Michael Snoyman <michael@snoyman.com>
+-- 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

Hack/Middleware/Jsonp.hs

@@ -0,0 +1,66 @@
+---------------------------------------------------------
+-- |
+-- Module        : Hack.Middleware.Jsonp
+-- Copyright     : Michael Snoyman
+-- License       : BSD3
+--
+-- Maintainer    : Michael Snoyman <michael@snoyman.com>
+-- 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

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

Web/Restful/Helpers/AtomFeed.hs

@@ -14,7 +14,7 @@
 --
 ---------------------------------------------------------
 
-module Web.Restful.Response.AtomFeed
+module Web.Restful.Helpers.AtomFeed
     ( AtomFeed (..)
     , AtomFeedEntry (..)
     ) where

Web/Restful/Helpers/Sitemap.hs

@@ -14,7 +14,7 @@
 --
 ---------------------------------------------------------
 
-module Web.Restful.Response.Sitemap
+module Web.Restful.Helpers.Sitemap
     ( sitemap
     , robots
     , SitemapUrl (..)

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]
     }

restful.cabal

@@ -1,5 +1,5 @@
 name:            restful
-version:         0.1.11
+version:         0.1.12
 license:         BSD3
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>
@@ -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