diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,5 +1,16 @@
# Changelog
+## 0.30
+
+* Use `Content-Disposition` to provide filenames for file responses.
+ This slightly changes the semantics of `FileO`: what used to be
+ interpreted as the file extension is now used for the whole file name.
+
+* `Rest.Types.Container.StringMap` Has been replaced by `rest-stringmap`. This
+ changes the XML serialization format of multi part messages, the old format
+ was `` and the new one is
+ ``.
+
## 0.29
* Add multi-delete handler. It is used on a DELETE to
diff --git a/rest-core.cabal b/rest-core.cabal
--- a/rest-core.cabal
+++ b/rest-core.cabal
@@ -1,5 +1,5 @@
Name: rest-core
-Version: 0.29
+Version: 0.30
Description: Rest API library.
Synopsis: Rest API library.
Maintainer: code@silk.co
@@ -28,12 +28,13 @@
, mtl >= 2.0 && < 2.2
, multipart >= 0.1.1 && < 0.2
, random == 1.0.*
- , rest-types == 1.9.*
+ , rest-stringmap == 0.1.*
+ , rest-types == 1.10.*
, safe >= 0.2 && < 0.4
, split >= 0.1 && < 0.3
, text >= 0.11 && < 1.2
- , tostring == 0.2.*
, transformers >= 0.2 && < 0.4
+ , unordered-containers == 0.2.*
, uri-encode == 1.5.*
, utf8-string == 0.3.*
, uuid >= 1.2 && < 1.4
diff --git a/src/Rest/Container.hs b/src/Rest/Container.hs
--- a/src/Rest/Container.hs
+++ b/src/Rest/Container.hs
@@ -1,11 +1,11 @@
{-# LANGUAGE
- TemplateHaskell
+ DeriveDataTypeable
, EmptyDataDecls
- , TypeFamilies
, FlexibleInstances
- , ScopedTypeVariables
- , DeriveDataTypeable
, GADTs
+ , ScopedTypeVariables
+ , TemplateHaskell
+ , TypeFamilies
#-}
module Rest.Container
( module Rest.Types.Container
@@ -18,12 +18,10 @@
) where
import Data.Maybe
-import Data.String
-import Data.String.ToString
-import Data.Typeable
import Rest.Dictionary
import Rest.Error
+import Rest.StringMap.HashMap.Strict
import Rest.Types.Container
listI :: Inputs a -> Maybe (Inputs (List a))
@@ -50,26 +48,26 @@
listDictO JsonO = Just JsonO
listDictO _ = Nothing
-mappingI :: forall k i. (Typeable k, IsString k, ToString k) => Inputs i -> Maybe (Inputs (StringMap k i))
+mappingI :: forall i. Inputs i -> Maybe (Inputs (StringHashMap String i))
mappingI None = Just (Dicts [XmlI, JsonI])
mappingI (Dicts is) =
case mapMaybe mappingDictI is of
[] -> Nothing
mis -> Just (Dicts mis)
where
- mappingDictI :: Input i -> Maybe (Input (StringMap k i))
+ mappingDictI :: Input i -> Maybe (Input (StringHashMap String i))
mappingDictI XmlI = Just XmlI
mappingDictI JsonI = Just JsonI
mappingDictI _ = Nothing
-mappingO :: forall k o. (Typeable k, IsString k, ToString k) => Outputs o -> Maybe (Outputs (StringMap k o))
+mappingO :: forall o. Outputs o -> Maybe (Outputs (StringHashMap String o))
mappingO None = Just (Dicts [XmlO, JsonO])
mappingO (Dicts os) =
case mapMaybe mappingDictO os of
[] -> Nothing
mos -> Just (Dicts mos)
where
- mappingDictO :: Output o -> Maybe (Output (StringMap k o))
+ mappingDictO :: Output o -> Maybe (Output (StringHashMap String o))
mappingDictO XmlO = Just XmlO
mappingDictO JsonO = Just JsonO
mappingDictO _ = Nothing
diff --git a/src/Rest/Driver/Perform.hs b/src/Rest/Driver/Perform.hs
--- a/src/Rest/Driver/Perform.hs
+++ b/src/Rest/Driver/Perform.hs
@@ -330,9 +330,11 @@
tryD (JsonO : _ ) JsonFormat = contentType JsonFormat >> ok (encode v)
tryD (StringO : _ ) StringFormat = contentType StringFormat >> ok (UTF8.fromString v)
tryD (MultipartO : _ ) _ = outputMultipart v
- tryD (FileO : _ ) FileFormat = do mime <- fromMaybe "application/octet-stream" <$> lookupMimeType (map toLower (snd v))
+ tryD (FileO : _ ) FileFormat = do let ext = (reverse . takeWhile (/='.') . reverse) $ snd v
+ mime <- fromMaybe "application/octet-stream" <$> lookupMimeType (map toLower ext)
setHeader "Content-Type" mime
setHeader "Cache-Control" "max-age=604800"
+ setHeader "Content-Disposition" ("filename=" ++ snd v)
ok (fst v)
tryD [] t = throwError (UnsupportedFormat (show t))
tryD (_ : xs) t = tryD xs t
diff --git a/src/Rest/Driver/RestM.hs b/src/Rest/Driver/RestM.hs
--- a/src/Rest/Driver/RestM.hs
+++ b/src/Rest/Driver/RestM.hs
@@ -11,48 +11,47 @@
import Control.Applicative
import Control.Monad.Reader
import Control.Monad.Writer
-import Data.Map (Map)
-
-import qualified Data.Map as Map
+import Data.HashMap.Strict (HashMap)
import qualified Data.ByteString.Lazy.UTF8 as UTF8
+import qualified Data.HashMap.Strict as H
import Rest.Driver.Perform (Rest)
-import qualified Rest.Driver.Types as Rest
import qualified Rest.Driver.Perform as Rest
+import qualified Rest.Driver.Types as Rest
data RestInput = RestInput
- { headers :: Map String String
- , parameters :: Map String String
- , body :: UTF8.ByteString
- , method :: Rest.Method
- , paths :: [String]
- , mimeTypes :: Map String String
+ { headers :: HashMap String String
+ , parameters :: HashMap String String
+ , body :: UTF8.ByteString
+ , method :: Rest.Method
+ , paths :: [String]
+ , mimeTypes :: HashMap String String
}
emptyInput :: RestInput
emptyInput = RestInput
- { headers = Map.empty
- , parameters = Map.empty
+ { headers = H.empty
+ , parameters = H.empty
, body = mempty
, method = Rest.GET
, paths = []
- , mimeTypes = Map.empty
+ , mimeTypes = H.empty
}
data RestOutput = RestOutput
- { headersSet :: Map String String
+ { headersSet :: HashMap String String
, responseCode :: Maybe Int
} deriving Show
instance Monoid RestOutput where
- mempty = RestOutput { headersSet = Map.empty, responseCode = Nothing }
+ mempty = RestOutput { headersSet = H.empty, responseCode = Nothing }
o1 `mappend` o2 = RestOutput
- { headersSet = headersSet o2 `Map.union` headersSet o1
+ { headersSet = headersSet o2 `H.union` headersSet o1
, responseCode = responseCode o2 <|> responseCode o1
}
outputHeader :: String -> String -> RestOutput
-outputHeader h v = mempty { headersSet = Map.singleton h v }
+outputHeader h v = mempty { headersSet = H.singleton h v }
outputCode :: Int -> RestOutput
outputCode cd = mempty { responseCode = Just cd }
@@ -70,11 +69,11 @@
runRestM_ i = fmap fst . runRestM i
instance (Functor m, Applicative m, Monad m) => Rest (RestM m) where
- getHeader h = RestM $ asks (Map.lookup h . headers )
- getParameter p = RestM $ asks (Map.lookup p . parameters)
+ getHeader h = RestM $ asks (H.lookup h . headers )
+ getParameter p = RestM $ asks (H.lookup p . parameters)
getBody = RestM $ asks body
getMethod = RestM $ asks method
getPaths = RestM $ asks paths
- lookupMimeType t = RestM $ asks (Map.lookup t . mimeTypes)
+ lookupMimeType t = RestM $ asks (H.lookup t . mimeTypes)
setHeader h v = RestM $ tell (outputHeader h v)
setResponseCode cd = RestM $ tell (outputCode cd)
diff --git a/src/Rest/Driver/Routing.hs b/src/Rest/Driver/Routing.hs
--- a/src/Rest/Driver/Routing.hs
+++ b/src/Rest/Driver/Routing.hs
@@ -4,6 +4,8 @@
, NamedFieldPuns
, FlexibleContexts
, StandaloneDeriving
+ , ViewPatterns
+ , NamedFieldPuns
, GADTs
, ScopedTypeVariables
, DeriveDataTypeable
@@ -34,13 +36,14 @@
import Safe
import qualified Control.Monad.State as State
import qualified Data.ByteString.Lazy.UTF8 as LUTF8
+import qualified Data.HashMap.Strict as H
import qualified Data.Label.Total as L
-import qualified Data.Map as Map
import Network.URI.Encode (decode)
import Rest.Api (Some1(..))
import Rest.Container
import Rest.Dictionary
+import qualified Rest.StringMap.HashMap.Strict as StringHashMap
import Rest.Error
import Rest.Handler (ListHandler, Handler, GenHandler (..), Env (..), range, mkInputHandler, Range (..))
import Rest.Types.Container.Resource (Resource, Resources (..))
@@ -308,11 +311,11 @@
mNewDict = L.traverse inputs mappingI
<=< L.traverse outputs (mappingO <=< statusO (L.get errors newErrDict))
$ newErrDict
- newAct (Env hs ps (StringMap vs)) =
- do bs <- lift $ forM vs $ \(k, v) -> runErrorT $
+ newAct (Env hs ps vs) =
+ do bs <- lift $ forM (StringHashMap.toList vs) $ \(k, v) -> runErrorT $
do i <- parseIdent sBy k
mapErrorT (run i) (act (Env hs ps v))
- return (StringMap (zipWith (\(k, _) b -> (k, eitherToStatus b)) vs bs))
+ return . StringHashMap.fromList $ zipWith (\(k, _) b -> (k, eitherToStatus b)) (StringHashMap.toList vs) bs
mkMultiGetHandler :: forall m s. (Applicative m, Monad m) => Rest.Router m s -> Handler m
mkMultiGetHandler root = mkInputHandler (xmlJsonI . someI . multipartO) $ \(Resources rs) -> multiGetHandler rs
@@ -332,13 +335,13 @@
routeResource uri = runRouter GET (splitUriString uri) (routeRoot root)
toRestInput r = Rest.emptyInput
- { Rest.headers = Map.map R.unValue . fromStringMap . R.headers $ r
- , Rest.parameters = Map.map R.unValue . fromStringMap . R.parameters $ r
+ { Rest.headers = H.map (R.unValue) . StringHashMap.toHashMap . R.headers $ r
+ , Rest.parameters = H.map (R.unValue) . StringHashMap.toHashMap . R.parameters $ r
, Rest.body = LUTF8.fromString (R.input r)
, Rest.paths = splitUriString (R.uri r)
}
- mkHeaders = map (first HeaderName) . Map.toList
+ mkHeaders = map (first HeaderName) . H.toList
mkBodyPart bdy restOutput =
let hdrs = (HeaderName "X-Response-Code", maybe "200" show (Rest.responseCode restOutput))
diff --git a/tests/Runner.hs b/tests/Runner.hs
--- a/tests/Runner.hs
+++ b/tests/Runner.hs
@@ -1,4 +1,7 @@
-{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}
+{-# LANGUAGE
+ OverloadedStrings
+ , ScopedTypeVariables
+ #-}
import Control.Applicative
import Control.Monad
@@ -6,12 +9,13 @@
import Data.Monoid
import Test.Framework (defaultMain)
import Test.Framework.Providers.HUnit (testCase)
-import Test.HUnit (Assertion, assertFailure, assertEqual)
+import Test.HUnit (Assertion, assertEqual, assertFailure)
import qualified Data.ByteString.Char8 as Char8
-import qualified Data.Map as Map
+import qualified Data.HashMap.Strict as H
import Rest.Api hiding (route)
+import Rest.Dictionary
import Rest.Driver.Perform (accept)
import Rest.Driver.RestM (runRestM_)
import Rest.Driver.Routing
@@ -19,8 +23,7 @@
import Rest.Handler
import Rest.Resource
import Rest.Schema
-import Rest.Dictionary
-import qualified Rest.Api as Rest
+import qualified Rest.Api as Rest
import qualified Rest.Driver.RestM as RestM
main :: IO ()
@@ -202,5 +205,5 @@
testAcceptHeaders :: Assertion
testAcceptHeaders =
- do fmt <- runRestM_ RestM.emptyInput { RestM.headers = Map.singleton "Accept" "text/json" } accept
+ do fmt <- runRestM_ RestM.emptyInput { RestM.headers = H.singleton "Accept" "text/json" } accept
assertEqual "Accept json format." [JsonFormat] fmt