Merge pull request #53 from garyb/headers

Include mime types in Requestable/Respondable for setting headers

Author: garyb

bower.json

@@ -24,6 +24,7 @@
   ],
   "dependencies": {
     "purescript-aff": "^0.13.0",
+    "purescript-argonaut-core": "^0.2.0",
     "purescript-arraybuffer-types": "^0.2.0",
     "purescript-dom": "^0.2.0",
     "purescript-foreign": "^0.7.0",

docs/Network.HTTP.Affjax.Request.md

@@ -18,11 +18,12 @@ instance requestableRequestContent :: Requestable RequestContent
 
 ``` purescript
 class Requestable a where
-  toRequest :: a -> RequestContent
+  toRequest :: a -> Tuple (Maybe MimeType) RequestContent
 ```
 
 A class for types that can be converted to values that can be sent with
-XHR requests.
+XHR requests. An optional mime-type can be specified for a default
+`Content-Type` header.
 
 ##### Instances
 ``` purescript
@@ -39,6 +40,7 @@ instance requestableFloat64Array :: Requestable (ArrayView Float64)
 instance requestableBlob :: Requestable Blob
 instance requestableDocument :: Requestable Document
 instance requestableString :: Requestable String
+instance requestableJson :: Requestable Json
 instance requestableFormData :: Requestable FormData
 instance requestableUnit :: Requestable Unit
 ```

docs/Network.HTTP.Affjax.Response.md

@@ -35,23 +35,26 @@ type ResponseContent = Foreign
 ```
 
 Type representing content types that be received from an XHR request
-(Blob, Document, JSON, String).
+(Blob, Document, JSON, String). An optional mime-type can be specified for
+a default `Accept` header.
 
 #### `Respondable`
 
 ``` purescript
 class Respondable a where
-  responseType :: ResponseType a
+  responseType :: Tuple (Maybe MimeType) (ResponseType a)
   fromResponse :: ResponseContent -> F a
 ```
 
 ##### Instances
 ``` purescript
 instance responsableBlob :: Respondable Blob
 instance responsableDocument :: Respondable Document
-instance responsableJSON :: Respondable Foreign
+instance responsableForeign :: Respondable Foreign
 instance responsableString :: Respondable String
 instance responsableUnit :: Respondable Unit
+instance responsableArrayBuffer :: Respondable ArrayBuffer
+instance responsableJson :: Respondable Json
 ```
 
 

package.json

@@ -8,7 +8,7 @@
     "gulp-jshint": "^1.11.2",
     "gulp-plumber": "^1.0.0",
     "gulp-purescript": "^0.6.0",
-    "purescript": "^0.7.4-rc.2",
+    "purescript": "^0.7.5",
     "xhr2": "^0.1.3"
   }
 }

src/Network/HTTP/Affjax.purs

@@ -17,28 +17,34 @@ module Network.HTTP.Affjax
   ) where
 
 import Prelude
-import Control.Alt ((<|>))
-import Control.Bind ((<=<))
+
 import Control.Monad.Aff (Aff(), makeAff, makeAff', Canceler(..), attempt, later', forkAff, cancel)
-import Control.Monad.Aff.Par (Par(..), runPar)
 import Control.Monad.Aff.AVar (AVAR(), makeVar, takeVar, putVar)
 import Control.Monad.Eff (Eff())
 import Control.Monad.Eff.Class (liftEff)
 import Control.Monad.Eff.Exception (Error(), error)
 import Control.Monad.Eff.Ref (REF(), newRef, readRef, writeRef)
 import Control.Monad.Error.Class (throwError)
+
+import Data.Array as Arr
 import Data.Either (Either(..), either)
-import Data.Foreign (Foreign(), F(), parseJSON, readString)
-import Data.Function (Fn5(), runFn5, Fn4(), runFn4)
+import Data.Foreign (Foreign())
+import Data.Foldable (any)
+import Data.Function (Fn5(), runFn5, Fn4(), runFn4, on)
 import Data.Int (toNumber, round)
-import Data.Maybe (Maybe(..), maybe)
+import Data.Maybe (Maybe(..))
 import Data.Nullable (Nullable(), toNullable)
-import DOM.XHR.Types (XMLHttpRequest())
+import Data.Tuple (Tuple(..), fst, snd)
+
 import Math (max, pow)
+
+import DOM.XHR.Types (XMLHttpRequest())
+
 import Network.HTTP.Affjax.Request
 import Network.HTTP.Affjax.Response
+import Network.HTTP.MimeType (MimeType())
 import Network.HTTP.Method (Method(..), methodToString)
-import Network.HTTP.RequestHeader (RequestHeader(), requestHeaderName, requestHeaderValue)
+import Network.HTTP.RequestHeader (RequestHeader(..), requestHeaderName, requestHeaderValue)
 import Network.HTTP.ResponseHeader (ResponseHeader(), responseHeader)
 import Network.HTTP.StatusCode (StatusCode(..))
 
@@ -202,23 +208,40 @@ affjax' :: forall e a b. (Requestable a, Respondable b) =>
 affjax' req eb cb =
   runFn5 _ajax responseHeader req' cancelAjax eb cb'
   where
+
   req' :: AjaxRequest
   req' = { method: methodToString req.method
          , url: req.url
-         , headers: (\h -> { field: requestHeaderName h, value: requestHeaderValue h }) <$> req.headers
-         , content: toNullable (toRequest <$> req.content)
-         , responseType: responseTypeToString (responseType :: ResponseType b)
+         , headers: (\h -> { field: requestHeaderName h, value: requestHeaderValue h }) <$> headers
+         , content: toNullable (snd requestSettings)
+         , responseType: responseTypeToString (snd responseSettings)
          , username: toNullable req.username
          , password: toNullable req.password
          }
+
+  requestSettings :: Tuple (Maybe MimeType) (Maybe RequestContent)
+  requestSettings = case toRequest <$> req.content of
+    Nothing -> Tuple Nothing Nothing
+    Just (Tuple mime rt) -> Tuple mime (Just rt)
+
+  responseSettings :: Tuple (Maybe MimeType) (ResponseType b)
+  responseSettings = responseType
+
+  headers :: Array RequestHeader
+  headers =
+    addHeader (ContentType <$> fst requestSettings) $
+      addHeader (Accept <$> fst responseSettings)
+        req.headers
+
+  addHeader :: Maybe RequestHeader -> Array RequestHeader -> Array RequestHeader
+  addHeader h hs = case h of
+    Just h | not $ any (on eq requestHeaderName h) hs -> hs `Arr.snoc` h
+    _ -> hs
+
   cb' :: AffjaxResponse ResponseContent -> Eff (ajax :: AJAX | e) Unit
-  cb' res = case res { response = _  } <$> fromResponse' res.response of
+  cb' res = case res { response = _  } <$> fromResponse res.response of
     Left err -> eb $ error (show err)
     Right res' -> cb res'
-  fromResponse' :: ResponseContent -> F b
-  fromResponse' = case (responseType :: ResponseType b) of
-    JSONResponse -> fromResponse <=< parseJSON <=< readString
-    _ -> fromResponse
 
 type AjaxRequest =
   { method :: String

src/Network/HTTP/Affjax/Request.purs

@@ -4,62 +4,78 @@ module Network.HTTP.Affjax.Request
   ) where
 
 import Prelude
+
+import Data.Argonaut.Core (Json())
+import Data.Maybe (Maybe(..))
+import Data.Tuple (Tuple(..))
+import qualified Data.ArrayBuffer.Types as A
+
 import DOM.File.Types (Blob())
 import DOM.Node.Types (Document())
 import DOM.XHR.Types (FormData())
+
 import qualified Unsafe.Coerce as U
-import qualified Data.ArrayBuffer.Types as A
+
+import Network.HTTP.MimeType (MimeType())
+import Network.HTTP.MimeType.Common (applicationJSON)
 
 -- | Type representing all content types that be sent via XHR (ArrayBufferView,
 -- | Blob, Document, String, FormData).
 foreign import data RequestContent :: *
 
 -- | A class for types that can be converted to values that can be sent with
--- | XHR requests.
+-- | XHR requests. An optional mime-type can be specified for a default
+-- | `Content-Type` header.
 class Requestable a where
-  toRequest :: a -> RequestContent
+  toRequest :: a -> Tuple (Maybe MimeType) RequestContent
+
+defaultToRequest :: forall a. a -> Tuple (Maybe MimeType) RequestContent
+defaultToRequest = Tuple Nothing <<< U.unsafeCoerce
 
 instance requestableRequestContent :: Requestable RequestContent where
-  toRequest = id
+  toRequest = defaultToRequest
 
 instance requestableInt8Array :: Requestable (A.ArrayView A.Int8) where
-  toRequest = U.unsafeCoerce
+  toRequest = defaultToRequest
 
 instance requestableInt16Array :: Requestable (A.ArrayView A.Int16) where
-  toRequest = U.unsafeCoerce
+  toRequest = defaultToRequest
 
 instance requestableInt32Array :: Requestable (A.ArrayView A.Int32) where
-  toRequest = U.unsafeCoerce
+  toRequest = defaultToRequest
 
 instance requestableUint8Array :: Requestable (A.ArrayView A.Uint8) where
-  toRequest = U.unsafeCoerce
+  toRequest = defaultToRequest
 
 instance requestableUint16Array :: Requestable (A.ArrayView A.Uint16) where
-  toRequest = U.unsafeCoerce
+  toRequest = defaultToRequest
 
 instance requestableUint32Array :: Requestable (A.ArrayView A.Uint32) where
-  toRequest = U.unsafeCoerce
+  toRequest = defaultToRequest
 
 instance requestableUint8ClampedArray :: Requestable (A.ArrayView A.Uint8Clamped) where
-  toRequest = U.unsafeCoerce
+  toRequest = defaultToRequest
 
 instance requestableFloat32Array :: Requestable (A.ArrayView A.Float32) where
-  toRequest = U.unsafeCoerce
+  toRequest = defaultToRequest
 
 instance requestableFloat64Array :: Requestable (A.ArrayView A.Float64) where
-  toRequest = U.unsafeCoerce
+  toRequest = defaultToRequest
 
 instance requestableBlob :: Requestable Blob where
-  toRequest = U.unsafeCoerce
+  toRequest = defaultToRequest
 
 instance requestableDocument :: Requestable Document where
-  toRequest = U.unsafeCoerce
+  toRequest = defaultToRequest
 
 instance requestableString :: Requestable String where
-  toRequest = U.unsafeCoerce
+  toRequest = defaultToRequest
+
+instance requestableJson :: Requestable Json where
+  toRequest json = Tuple (Just applicationJSON) (U.unsafeCoerce (show json))
 
 instance requestableFormData :: Requestable FormData where
-  toRequest = U.unsafeCoerce
+  toRequest = defaultToRequest
 
 instance requestableUnit :: Requestable Unit where
-  toRequest = U.unsafeCoerce
+  toRequest = defaultToRequest

src/Network/HTTP/Affjax/Response.purs

@@ -5,12 +5,24 @@ module Network.HTTP.Affjax.Response
   ) where
 
 import Prelude
+
+import Control.Bind ((<=<))
+
+import Data.Argonaut.Core (Json())
 import Data.Either (Either(..))
-import Data.Foreign (Foreign(), F(), readString, unsafeReadTagged)
+import Data.Foreign (Foreign(), F(), parseJSON, readString, unsafeReadTagged)
+import Data.Maybe (Maybe(..))
+import Data.Tuple (Tuple(..))
+import qualified Data.ArrayBuffer.Types as A
+
 import DOM.File.Types (Blob())
 import DOM.Node.Types (Document())
 import DOM.XHR.Types (FormData())
-import qualified Data.ArrayBuffer.Types as A
+
+import Unsafe.Coerce (unsafeCoerce)
+
+import Network.HTTP.MimeType (MimeType())
+import Network.HTTP.MimeType.Common (applicationJSON)
 
 -- | Valid response types for an AJAX request. This is used to determine the
 -- | `ResponseContent` type for a request. The `a` type variable is a phantom
@@ -46,33 +58,38 @@ responseTypeToString JSONResponse = "text" -- IE doesn't support "json" response
 responseTypeToString StringResponse = "text"
 
 -- | Type representing content types that be received from an XHR request
--- | (Blob, Document, JSON, String).
+-- | (Blob, Document, JSON, String). An optional mime-type can be specified for
+-- | a default `Accept` header.
 type ResponseContent = Foreign
 
 class Respondable a where
-  responseType :: ResponseType a
+  responseType :: Tuple (Maybe MimeType) (ResponseType a)
   fromResponse :: ResponseContent -> F a
 
 instance responsableBlob :: Respondable Blob where
-  responseType = BlobResponse
+  responseType = Tuple Nothing BlobResponse
   fromResponse = unsafeReadTagged "Blob"
 
 instance responsableDocument :: Respondable Document where
-  responseType = DocumentResponse
+  responseType = Tuple Nothing DocumentResponse
   fromResponse = unsafeReadTagged "Document"
 
-instance responsableJSON :: Respondable Foreign where
-  responseType = JSONResponse
-  fromResponse = Right
+instance responsableForeign :: Respondable Foreign where
+  responseType = Tuple Nothing JSONResponse
+  fromResponse = parseJSON <=< readString
 
 instance responsableString :: Respondable String where
-  responseType = StringResponse
+  responseType = Tuple Nothing StringResponse
   fromResponse = readString
 
 instance responsableUnit :: Respondable Unit where
-  responseType = StringResponse
+  responseType = Tuple Nothing StringResponse
   fromResponse = const (Right unit)
 
 instance responsableArrayBuffer :: Respondable A.ArrayBuffer where
-  responseType = ArrayBufferResponse
+  responseType = Tuple Nothing ArrayBufferResponse
   fromResponse = unsafeReadTagged "ArrayBuffer"
+
+instance responsableJson :: Respondable Json where
+  responseType = Tuple (Just applicationJSON) JSONResponse
+  fromResponse = Right <<< unsafeCoerce