summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorlambda_foo <>2017-11-13 23:38:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-11-13 23:38:00 (GMT)
commit4127b8edbf1266d2f7c0910b576d81ecdcd89b53 (patch)
tree95748416d1866d1dc1e187604d9306cf490ff1b0
parent69a7d02ada87bf5de2380a8dc3b9cd0922b19c69 (diff)
version 0.9.0HEAD0.9.0master
-rw-r--r--Changes.md5
-rw-r--r--LICENSE37
-rw-r--r--README.md23
-rw-r--r--airship.cabal126
-rw-r--r--src/Airship/Helpers.hs1
-rw-r--r--src/Airship/Internal/Date.hs111
-rw-r--r--src/Airship/Internal/Decision.hs8
-rw-r--r--src/Airship/Internal/Helpers.hs59
-rw-r--r--src/Airship/Internal/Route.hs229
-rw-r--r--src/Airship/RST.hs161
-rw-r--r--src/Airship/Resource.hs3
-rw-r--r--src/Airship/Route.hs5
-rw-r--r--src/Airship/Types.hs111
13 files changed, 677 insertions, 202 deletions
diff --git a/Changes.md b/Changes.md
new file mode 100644
index 0000000..7c7cc84
--- /dev/null
+++ b/Changes.md
@@ -0,0 +1,5 @@
+ * 0.9.0
+ - Handle unspecified content-type (#107)
+ - Unroll internal webmachine monad (#108)
+ - Support for GHC 8.2.1
+ - Various bugfixes
diff --git a/LICENSE b/LICENSE
index 1695adc..60ef223 100644
--- a/LICENSE
+++ b/LICENSE
@@ -18,3 +18,40 @@ IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+Portions of this software have been extracted from the Snap framework,
+which is licensed under the three-clause BSD license.
+
+Copyright (c) 2009, Snap Framework authors (see CONTRIBUTORS)
+All rights reserved.
+
+Portions of this software have been extracted from Kazu Yamamoto's
+http-date library, which is licensed under the three-clause BSD license.
+
+Copyright (c) 2009, IIJ Innovation Institute Inc.
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+Redistributions of source code must retain the above copyright notice, this
+list of conditions and the following disclaimer.
+
+Redistributions in binary form must reproduce the above copyright notice, this
+list of conditions and the following disclaimer in the documentation and/or
+other materials provided with the distribution.
+
+Neither the name of the Snap Framework authors nor the names of its
+contributors may be used to endorse or promote products derived from this
+software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..f10d910
--- /dev/null
+++ b/README.md
@@ -0,0 +1,23 @@
+# Airship
+
+[![Join the chat at https://gitter.im/helium/airship](https://badges.gitter.im/Join%20Chat.svg)](https://gitter.im/helium/airship?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge)
+
+[![Build Status](https://travis-ci.org/helium/airship.svg?branch=master)](https://travis-ci.org/helium/airship)
+
+Airship is a Haskell library for handling and serving HTTP requests in a RESTful fashion. It is heavily inspired by [Webmachine](https://github.com/basho/webmachine) and works with any [WAI](https://hackage.haskell.org/package/wai)-compatible web server such as [Warp](https://hackage.haskell.org/package/warp). It aims to be small, fast, and flexible.
+
+# How does it work?
+
+Airship resources are represented with a [`Resource` record type](https://github.com/helium/airship/blob/master/src/Airship/Resource.hs#L39-L117). Each field in `Resource` corresponds to an action taken in the [Webmachine decision tree](https://raw.githubusercontent.com/wiki/Webmachine/webmachine/images/http-headers-status-v3.png). Airship provides a `defaultResource` with sensible defaults for each of these actions; you build web services by overriding fields in the default resource with your own.
+
+Routes are declared with a simple monadic syntax:
+
+```haskell
+routes = do
+ root #> someRootResource
+ "account" </> var "name" #> accountResource
+```
+
+For a simple example that handles HTTP GET and POST requests, please check [`example/Basic.hs`](https://github.com/helium/airship/blob/master/example/Basic.hs). For a slightly more involved example that generates HTML and manages a pool of resources, please check the [blimp](https://github.com/patrickt/blimp) repository.
+
+Airship is copyright &copy; 2015 Helium Systems, Inc., and released to the public under the terms of the MIT license.
diff --git a/airship.cabal b/airship.cabal
index 4692227..56c78bb 100644
--- a/airship.cabal
+++ b/airship.cabal
@@ -1,60 +1,66 @@
-name: airship
-synopsis: A Webmachine-inspired HTTP library
-description: A Webmachine-inspired HTTP library
-homepage: https://github.com/helium/airship/
-Bug-reports: https://github.com/helium/airship/issues
-version: 0.6.0
-license: MIT
-license-file: LICENSE
-author: Reid Draper and Patrick Thomson
-maintainer: reid@helium.com
-category: Web
-build-type: Simple
-cabal-version: >=1.10
+name: airship
+synopsis: A Webmachine-inspired HTTP library
+homepage: https://github.com/helium/airship/
+Bug-reports: https://github.com/helium/airship/issues
+version: 0.9.0
+license: MIT
+license-file: LICENSE
+author: Reid Draper and Patrick Thomson
+maintainer: Tim McGilchrist <timmcgil@gmail.com>, reid@helium.com
+category: Web
+build-type: Simple
+cabal-version: >=1.10
+description: A Webmachine-inspired HTTP library based off ideas from the original Erlang project <https://github.com/webmachine/webmachine>
+ .
+ A number of examples can be found in <https://github.com/helium/airship/tree/master/example> illustrating how to build airship based services.
+extra-source-files:
+ README.md
+ Changes.md
source-repository head
- type: git
- location: https://github.com/helium/airship.git
+ type: git
+ location: https://github.com/helium/airship.git
library
- default-language: Haskell2010
- hs-source-dirs: src
- ghc-options: -Wall
- exposed-modules: Airship
- , Airship.Config
- , Airship.Headers
- , Airship.Helpers
- , Airship.Types
- , Airship.Resource
- , Airship.Resource.Static
- , Airship.Route
+ default-language: Haskell2010
+ hs-source-dirs: src
+ ghc-options: -Wall
+ exposed-modules: Airship
+ , Airship.RST
+ , Airship.Config
+ , Airship.Headers
+ , Airship.Helpers
+ , Airship.Types
+ , Airship.Resource
+ , Airship.Resource.Static
+ , Airship.Route
- other-modules: Airship.Internal.Route
- , Airship.Internal.Date
- , Airship.Internal.Decision
- , Airship.Internal.Helpers
- , Airship.Internal.Parsers
+ other-modules: Airship.Internal.Route
+ , Airship.Internal.Date
+ , Airship.Internal.Decision
+ , Airship.Internal.Helpers
+ , Airship.Internal.Parsers
build-depends: attoparsec
- , base >= 4.7 && < 5
- , base64-bytestring == 1.0.*
- , blaze-builder >= 0.3 && < 0.5
+ , base >= 4.7 && < 5
+ , base64-bytestring == 1.0.*
+ , blaze-builder >= 0.3 && < 0.5
, bytestring
- , bytestring-trie == 0.2.4.*
+ , bytestring-trie == 0.2.4.*
, case-insensitive
, containers
- , cryptohash == 0.11.*
+ , cryptohash == 0.11.*
, directory
- , either >= 4.3 && < 4.6
- , filepath >= 1.3 && < 1.5
+ , either >= 4.3 && < 4.6
+ , filepath >= 1.3 && < 1.5
, http-date
, http-media
- , http-types >= 0.8 && <0.10
- , lifted-base == 0.2.*
+ , http-types >= 0.8 && <0.10
+ , lifted-base == 0.2.*
, microlens
- , monad-control >= 1.0
- , mime-types == 0.1.0.*
- , mmorph == 1.0.*
+ , monad-control >= 1.0
+ , mime-types == 0.1.0.*
+ , mmorph >= 1.0 && < 1.2
, mtl
, network
, old-locale
@@ -63,24 +69,24 @@ library
, time
, transformers
, transformers-base
- , unix == 2.7.*
+ , unix == 2.7.*
, unordered-containers
- , wai >= 3.0 && < 3.3
- , wai-extra == 3.0.*
+ , wai >= 3.0 && < 3.3
+ , wai-extra == 3.0.*
test-suite unit
- default-language: Haskell2010
- type: exitcode-stdio-1.0
- hs-source-dirs: test/unit
- main-is: test.hs
- build-depends: base >= 4.7 && < 5
- , airship
- , text == 1.2.*
- , bytestring >= 0.9.1 && < 0.11
- , tasty >= 0.10.1 && < 0.12
- , tasty-quickcheck >= 0.8.3 && < 0.8.5
- , tasty-hunit >= 0.9.1 && < 0.10
- , transformers
- , wai >= 3.0 && < 3.3
+ default-language: Haskell2010
+ type: exitcode-stdio-1.0
+ hs-source-dirs: test/unit
+ main-is: test.hs
+ build-depends: base >= 4.7 && < 5
+ , airship
+ , text == 1.2.*
+ , bytestring >= 0.9.1 && < 0.11
+ , tasty >= 0.10.1 && < 0.12
+ , tasty-quickcheck >= 0.8.3 && < 0.8.5
+ , tasty-hunit >= 0.9.1 && < 0.10
+ , transformers
+ , wai >= 3.0 && < 3.3
- ghc-options: -Wall -threaded -O1 -fno-warn-orphans
+ ghc-options: -Wall -threaded -fno-warn-orphans
diff --git a/src/Airship/Helpers.hs b/src/Airship/Helpers.hs
index 8ad8e52..8b17ce0 100644
--- a/src/Airship/Helpers.hs
+++ b/src/Airship/Helpers.hs
@@ -5,6 +5,7 @@ module Airship.Helpers
, redirectPermanently
, resourceToWai
, resourceToWaiT
+ , resourceToWaiT'
, appendRequestPath
, lookupParam
, lookupParam'
diff --git a/src/Airship/Internal/Date.hs b/src/Airship/Internal/Date.hs
index 8423164..efaa418 100644
--- a/src/Airship/Internal/Date.hs
+++ b/src/Airship/Internal/Date.hs
@@ -1,26 +1,31 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+{-
+ Portions of this file are copyright (c) 2009, IIJ Innovation Institute Inc.
+ The utcTimeToRfc1123 function was extracted from http-date, with slight
+ modifications to operate on UTCTime values.
+-}
module Airship.Internal.Date
( parseRfc1123Date
, utcTimeToRfc1123) where
#if __GLASGOW_HASKELL__ < 710
-import Control.Applicative ((<$>))
+import Control.Applicative ((<$>))
#endif
-import Data.ByteString.Char8 (ByteString, pack)
-import Data.Time.Calendar (fromGregorian)
-import Data.Time.Clock (UTCTime(..), secondsToDiffTime)
-
-#if MIN_VERSION_time(1,5,0)
-import Data.Time.Format (formatTime, defaultTimeLocale)
-#else
--- get defaultTimeLocale from old-locale
-import Data.Time.Format (formatTime)
-import System.Locale (defaultTimeLocale)
-#endif
+import Data.ByteString.Char8 ()
+import Data.ByteString.Internal
+import Data.Time.Calendar (fromGregorian, toGregorian)
+import Data.Time.Calendar.WeekDate (toWeekDate)
+import Data.Time.Clock (UTCTime (..), secondsToDiffTime)
+import Data.Word
+import Foreign.ForeignPtr
+import Foreign.Ptr
+import Foreign.Storable
-import qualified Network.HTTP.Date as HD
+import qualified Network.HTTP.Date as HD
httpDateToUtc :: HD.HTTPDate -> UTCTime
httpDateToUtc h = UTCTime days diffTime
@@ -34,4 +39,80 @@ parseRfc1123Date :: ByteString -> Maybe UTCTime
parseRfc1123Date b = httpDateToUtc <$> HD.parseHTTPDate b
utcTimeToRfc1123 :: UTCTime -> ByteString
-utcTimeToRfc1123 utc = pack $ formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT" utc
+utcTimeToRfc1123 (UTCTime day offset) =
+ unsafeCreate 29 $ \ptr -> do
+ cpy3 ptr weekDays (3 * w)
+ poke (ptr `plusPtr` 3) comma
+ poke (ptr `plusPtr` 4) spc
+ int2 (ptr `plusPtr` 5) d
+ poke (ptr `plusPtr` 7) spc
+ cpy3 (ptr `plusPtr` 8) months (3 * m)
+ poke (ptr `plusPtr` 11) spc
+ int4 (ptr `plusPtr` 12) y
+ poke (ptr `plusPtr` 16) spc
+ int2 (ptr `plusPtr` 17) h
+ poke (ptr `plusPtr` 19) colon
+ int2 (ptr `plusPtr` 20) n
+ poke (ptr `plusPtr` 22) colon
+ int2 (ptr `plusPtr` 23) s
+ poke (ptr `plusPtr` 25) spc
+ poke (ptr `plusPtr` 26) (71 :: Word8)
+ poke (ptr `plusPtr` 27) (77 :: Word8)
+ poke (ptr `plusPtr` 28) (84 :: Word8)
+ where
+ y = fromIntegral y'
+ offset' = round offset
+ h = offset' `mod` 3600
+ n = offset' `mod` 60
+ s = offset' - (h * 3600) - (n * 60)
+ (y', m, d) = toGregorian day
+ (_, _, w) = toWeekDate day
+ cpy3 :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO ()
+ cpy3 ptr p o = withForeignPtr p $ \fp ->
+ memcpy ptr (fp `plusPtr` o) 3
+
+----------------------------------------------------------------
+
+int2 :: Ptr Word8 -> Int -> IO ()
+int2 ptr n
+ | n < 10 = do
+ poke ptr zero
+ poke (ptr `plusPtr` 1) (i2w8 n)
+ | otherwise = do
+ poke ptr (i2w8 (n `quot` 10))
+ poke (ptr `plusPtr` 1) (i2w8 (n `rem` 10))
+
+int4 :: Ptr Word8 -> Int -> IO ()
+int4 ptr n0 = do
+ let (n1,x1) = n0 `quotRem` 10
+ (n2,x2) = n1 `quotRem` 10
+ (x4,x3) = n2 `quotRem` 10
+ poke ptr (i2w8 x4)
+ poke (ptr `plusPtr` 1) (i2w8 x3)
+ poke (ptr `plusPtr` 2) (i2w8 x2)
+ poke (ptr `plusPtr` 3) (i2w8 x1)
+
+i2w8 :: Int -> Word8
+i2w8 n = fromIntegral n + zero
+
+----------------------------------------------------------------
+
+months :: ForeignPtr Word8
+months = let (PS p _ _) = "___JanFebMarAprMayJunJulAugSepOctNovDec" in p
+
+weekDays :: ForeignPtr Word8
+weekDays = let (PS p _ _) = "___MonTueWedThuFriSatSun" in p
+
+----------------------------------------------------------------
+
+spc :: Word8
+spc = 32
+
+comma :: Word8
+comma = 44
+
+colon :: Word8
+colon = 58
+
+zero :: Word8
+zero = 48
diff --git a/src/Airship/Internal/Decision.hs b/src/Airship/Internal/Decision.hs
index d8c5005..d70e694 100644
--- a/src/Airship/Internal/Decision.hs
+++ b/src/Airship/Internal/Decision.hs
@@ -17,7 +17,8 @@ import Airship.Resource (PostResponse (..),
Resource (..))
import Airship.Types (Response (..),
ResponseBody (..),
- Webmachine, etagToByteString,
+ Webmachine, addTrace,
+ etagToByteString,
getResponseBody,
getResponseHeaders, halt,
pathInfo, putResponseBody,
@@ -30,7 +31,6 @@ import Control.Monad (when)
import Control.Monad.Trans (lift)
import Control.Monad.Trans.State.Strict (StateT (..), evalStateT, get,
modify)
-import Control.Monad.Writer.Class (tell)
import Blaze.ByteString.Builder (toByteString)
@@ -81,8 +81,8 @@ initFlowState = FlowState Nothing
flow :: Monad m => Resource m -> Webmachine m Response
flow r = evalStateT (b13 r) initFlowState
-trace :: Monad m => Text -> FlowStateT m ()
-trace t = lift $ tell [t]
+trace :: Monad m => ByteString -> FlowStateT m ()
+trace a = lift $ addTrace a
-----------------------------------------------------------------------------
-- Header value data newtypes
diff --git a/src/Airship/Internal/Helpers.hs b/src/Airship/Internal/Helpers.hs
index 3d4ac74..163148d 100644
--- a/src/Airship/Internal/Helpers.hs
+++ b/src/Airship/Internal/Helpers.hs
@@ -11,6 +11,7 @@ module Airship.Internal.Helpers
, redirectPermanently
, resourceToWai
, resourceToWaiT
+ , resourceToWaiT'
, appendRequestPath
, lookupParam
, lookupParam'
@@ -20,7 +21,7 @@ module Airship.Internal.Helpers
import Control.Applicative
#endif
import Control.Monad (join)
-import Data.ByteString (ByteString)
+import Data.ByteString (ByteString, intercalate)
import qualified Data.ByteString.Lazy as LB
import Data.Maybe
#if __GLASGOW_HASKELL__ < 710
@@ -29,8 +30,8 @@ import Data.Monoid
import Data.Foldable (forM_)
import qualified Data.HashMap.Strict as HM
import qualified Data.Map.Strict as M
-import Data.Text (Text, intercalate)
-import Data.Text.Encoding
+import Data.Text (Text)
+import Data.Text.Encoding (decodeUtf8)
import Data.Time (getCurrentTime)
import Lens.Micro ((^.))
import Network.HTTP.Media
@@ -105,29 +106,49 @@ resourceToWai :: AirshipConfig
resourceToWai cfg routes errors =
resourceToWaiT cfg (const id) routes errors
--- | Given a 'RoutingSpec', an 'ErrorResponses', and a user state @s@, construct a WAI 'Application'.
-resourceToWaiT :: Monad m =>
- AirshipConfig
- -> (Request -> m Wai.Response -> IO Wai.Response)
+-- | Given a 'AirshipConfig, a function to modify the 'Response' based on the
+-- 'AirshipRequest' and the 'Response' (like WAI middleware), a 'RoutingSpec,
+-- and 'ErrorResponses' construct a WAI 'Application'.
+resourceToWaiT :: Monad m
+ => AirshipConfig
+ -> (AirshipRequest -> m Wai.Response -> IO Wai.Response)
-> RoutingSpec m ()
-> ErrorResponses m
-> Wai.Application
-resourceToWaiT cfg run routes errors req respond = do
- let routeMapping = runRouter routes
- pInfo = Wai.pathInfo req
+resourceToWaiT cfg run routes errors req respond =
+ resourceToWaiT' cfg run (runRouter routes) errors req respond
+
+-- | Like 'resourceToWaiT', but expects the 'RoutingSpec' to have been
+-- evaluated with 'runRouter'. This is more efficient than 'resourceToWaiT', as
+-- the routes will not be evaluated on every request.
+--
+-- Given @routes :: RoutingSpec IO ()@, 'resourceToWaiT'' can be invoked like so:
+--
+-- > resourceToWaiT' cfg (const id) (runRouter routes) errors
+resourceToWaiT' :: Monad m
+ => AirshipConfig
+ -> (AirshipRequest -> m Wai.Response -> IO Wai.Response)
+ -> Trie (RouteLeaf m)
+ -> ErrorResponses m
+ -> Wai.Application
+resourceToWaiT' cfg run routeMapping errors req respond = do
+ let pInfo = Wai.rawPathInfo req
quip <- getQuip
nowTime <- getCurrentTime
- let (er, (ps, matched), r) =
+ let (er, (reqParams, dispatched), routePath', r) =
case route routeMapping pInfo of
Nothing ->
- (errors, (mempty, []), return $ Response HTTP.status404 [(HTTP.hContentType, "text/plain")] Empty)
- Just (resource, pm) ->
- (M.union (errorResponses resource) errors, pm, flow resource)
- respond =<< run req (do
- (response, trace) <- eitherResponse nowTime ps matched req (r >>= errorResponse er)
+ (errors, (mempty, []), decodeUtf8 pInfo, return $ Response HTTP.status404 [(HTTP.hContentType, "text/plain")] Empty)
+ Just (RoutedResource rPath resource, pm) ->
+ (M.union (errorResponses resource) errors, pm, routeText rPath, flow resource)
+ airshipReq = AirshipRequest req routePath'
+ requestReader = RequestReader nowTime airshipReq
+ startingState = ResponseState [] Empty reqParams dispatched []
+ respond =<< run airshipReq (do
+ (response, trace) <-
+ eitherResponse requestReader startingState (r >>= errorResponse er)
return $ toWaiResponse response cfg (traceHeader trace) quip)
-
-- | If the Response body is Empty the response body is set based on the error responses
-- provided by the application and resource. If the response body is not Empty or
-- there are no error response configured for the status code in the Response then no
@@ -176,8 +197,8 @@ getQuip = do
, "shut it down"
]
-traceHeader :: [Text] -> ByteString
-traceHeader = encodeUtf8 . intercalate ","
+traceHeader :: [ByteString] -> ByteString
+traceHeader = intercalate ","
-- | Lookup routing parameter and return 500 Internal Server Error if not found.
-- Not finding the paramter usually means the route doesn't match what
diff --git a/src/Airship/Internal/Route.hs b/src/Airship/Internal/Route.hs
index 09aa48a..fb00abe 100644
--- a/src/Airship/Internal/Route.hs
+++ b/src/Airship/Internal/Route.hs
@@ -1,22 +1,48 @@
-{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
-
-module Airship.Internal.Route where
-
-import Airship.Resource
-
-import Data.Foldable (foldr')
-import Data.HashMap.Strict (HashMap, insert)
+{-# OPTIONS_HADDOCK hide #-}
+
+module Airship.Internal.Route
+ ( RoutingSpec
+ , Route
+ , RouteLeaf
+ , RoutedResource(..)
+ , Trie
+ , root
+ , var
+ , star
+ , (</>)
+ , (#>)
+ , (#>=)
+ , runRouter
+ , route
+ , routeText
+ ) where
+
+import Airship.Resource as Resource
+
+import Control.Monad.Writer.Class (MonadWriter, tell)
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Base64 as Base64
+import qualified Data.ByteString.Char8 as BC8
+import Data.HashMap.Strict (HashMap, fromList)
+import qualified Data.List as L (foldl')
+import Data.Maybe (isNothing)
import Data.Monoid
import Data.Text (Text)
+import qualified Data.Text as T (intercalate, cons)
+import Data.Text.Encoding (encodeUtf8, decodeUtf8)
+import Data.Trie (Trie)
+import qualified Data.Trie as Trie
+
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
import Control.Monad.Writer (Writer, WriterT (..), execWriter)
-import Control.Monad.Writer.Class (MonadWriter)
import Data.String (IsString, fromString)
@@ -25,15 +51,59 @@ import Data.String (IsString, fromString)
-- named variables with the 'var' combinator, and wildcards with 'star'.
newtype Route = Route { getRoute :: [BoundOrUnbound] } deriving (Show, Monoid)
+routeText :: Route -> Text
+routeText (Route parts) =
+ T.cons '/' $ T.intercalate "/" ((boundOrUnboundText <$> parts))
+
data BoundOrUnbound = Bound Text
| Var Text
| RestUnbound deriving (Show)
+
+boundOrUnboundText :: BoundOrUnbound -> Text
+boundOrUnboundText (Bound t) = t
+boundOrUnboundText (Var t) = ":" <> t
+boundOrUnboundText (RestUnbound) = "*"
+
+
+
+
instance IsString Route where
fromString s = Route [Bound (fromString s)]
-runRouter :: RoutingSpec m a -> [(Route, Resource m)]
-runRouter routes = execWriter (getRouter routes)
+
+data RoutedResource m
+ = RoutedResource Route (Resource m)
+
+
+data RouteLeaf m = RouteMatch (RoutedResource m) [Text]
+ | RVar
+ | RouteMatchOrVar (RoutedResource m) [Text]
+ | Wildcard (RoutedResource m)
+
+
+-- | Turns the list of routes in a 'RoutingSpec' into a 'Trie' for efficient
+-- routing
+runRouter :: RoutingSpec m a -> Trie (RouteLeaf m)
+runRouter routes = toTrie $ execWriter (getRouter routes)
+ where
+ -- Custom version of Trie.fromList that resolves key conflicts
+ -- in the desired manner. In the case of duplicate routes the
+ -- routes specified first are favored over any subsequent
+ -- specifications.
+ toTrie = L.foldl' insertOrReplace Trie.empty
+ insertOrReplace t (k, v) =
+ let newV = maybe v (mergeValues v) $ Trie.lookup k t
+ in Trie.insert k newV t
+ mergeValues (Wildcard x) _ = Wildcard x
+ mergeValues _ (Wildcard x) = Wildcard x
+ mergeValues RVar RVar = RVar
+ mergeValues RVar (RouteMatch x y) = RouteMatchOrVar x y
+ mergeValues (RouteMatch _ _) (RouteMatch x y) = RouteMatch x y
+ mergeValues (RouteMatch x y) RVar = RouteMatchOrVar x y
+ mergeValues (RouteMatchOrVar _ _) (RouteMatch x y) = RouteMatchOrVar x y
+ mergeValues (RouteMatchOrVar x y) _ = RouteMatchOrVar x y
+ mergeValues _ v = v
-- | @a '</>' b@ separates the path components @a@ and @b@ with a slash.
-- This is actually just a synonym for 'mappend'.
@@ -65,6 +135,42 @@ var t = Route [Var t]
star :: Route
star = Route [RestUnbound]
+
+-- Routing trie creation algorithm
+-- 1. Store full paths as keys up to first `var`
+-- 2. Calculate Base64 encoding of the URL portion preceding the
+-- `var` ++ "var" and use that as key for the next part of the
+-- route spec.
+-- 3. Repeat step 2 for every `var` encountered until the route
+ -- is completed and maps to a resource.
+(#>) :: MonadWriter [(B.ByteString, (RouteLeaf a))] m
+ => Route -> Resource a -> m ()
+k #> v = do
+ let (key, routes, vars, isWild) = foldl routeFoldFun ("", [], [], False) (getRoute k)
+ key' = if BC8.null key then "/"
+ else key
+ ctor = if isWild
+ then Wildcard (RoutedResource k v)
+ else RouteMatch (RoutedResource k v) vars
+ tell $ (key', ctor) : routes
+ where
+ routeFoldFun (kps, rt, vs, False) (Bound x) =
+ (B.concat [kps, "/", encodeUtf8 x], rt, vs, False)
+ routeFoldFun (kps, rt, vs, False) (Var x) =
+ let partKey = Base64.encode $ B.concat [kps, "var"]
+ rt' = (kps, RVar) : rt
+ in (partKey, rt', x:vs, False)
+ routeFoldFun (kps, rt, vs, False) RestUnbound =
+ (kps, rt, vs, True)
+ routeFoldFun (kps, rt, vs, True) _ =
+ (kps, rt, vs, True)
+
+
+(#>=) :: MonadWriter [(B.ByteString, (RouteLeaf a))] m
+ => Route -> m (Resource a) -> m ()
+k #>= mv = mv >>= (k #>)
+
+
-- | Represents a fully-specified set of routes that map paths (represented as 'Route's) to 'Resource's. 'RoutingSpec's are declared with do-notation, to wit:
--
-- @
@@ -76,40 +182,67 @@ star = Route [RestUnbound]
-- "anything" '</>' star #> wildcardResource
-- @
--
-newtype RoutingSpec m a = RoutingSpec { getRouter :: Writer [(Route, Resource m)] a }
- deriving (Functor, Applicative, Monad, MonadWriter [(Route, Resource m)])
-
-type MatchedRoute a = (a, (HashMap Text Text, [Text]))
-
-route :: [(Route, a)]
- -> [Text]
- -> Maybe (MatchedRoute a)
-route routes pInfo = foldr' (matchRoute pInfo) Nothing routes
-
-matchRoute :: [Text]
- -> (Route, a)
- -> Maybe (MatchedRoute a)
- -> Maybe (MatchedRoute a)
-matchRoute paths (rSpec, resource) previousMatch =
- case matchesRoute paths rSpec of
- Nothing -> previousMatch
- Just m -> Just (resource, m)
-
-matchesRoute :: [Text] -> Route -> Maybe (HashMap Text Text, [Text])
-matchesRoute paths spec = matchesRoute' paths (getRoute spec) (mempty, mempty) False where
- -- recursion is over, and we never bailed out to return false, so we match
- matchesRoute' [] [] acc _ = Just acc
- -- there is an extra part of the path left, and we don't have more matching
- matchesRoute' (_ph:_ptl) [] _ _ = Nothing
- -- we match whatever is left, so it doesn't matter what's left in the path
- matchesRoute' r (RestUnbound:_) (h, d) _ = Just (h, d ++ r)
- -- we match a specific string, and it matches this part of the path,
- -- so recur
- matchesRoute' (ph:ptl) (Bound sh:stt) (h, dispatch) True
- | ph == sh
- = matchesRoute' ptl stt (h, dispatch ++ [ph]) True
- matchesRoute' (ph:ptl) (Bound sh:stt) (h, dispatch) False
- | ph == sh
- = matchesRoute' ptl stt (h, dispatch) False
- matchesRoute' (ph:ptl) (Var t:stt) acc _ = matchesRoute' ptl stt (insert t ph (fst acc), snd acc) True
- matchesRoute' _ _ _acc _ = Nothing
+newtype RoutingSpec m a = RoutingSpec {
+ getRouter :: Writer [(B.ByteString, RouteLeaf m)] a
+ } deriving ( Functor, Applicative, Monad
+ , MonadWriter [(B.ByteString, RouteLeaf m)]
+ )
+
+
+route :: Trie (RouteLeaf a)
+ -> BC8.ByteString
+ -> Maybe (RoutedResource a, (HashMap Text Text, [Text]))
+route routes pInfo = let matchRes = Trie.match routes pInfo
+ in matchRoute' routes matchRes mempty Nothing
+
+
+matchRoute' :: Trie (RouteLeaf a)
+ -> Maybe (B.ByteString, RouteLeaf a, B.ByteString)
+ -> [Text]
+ -> Maybe B.ByteString
+ -> Maybe (RoutedResource a, (HashMap Text Text, [Text]))
+matchRoute' _routes Nothing _ps _dsp =
+ -- Nothing even partially matched the route
+ Nothing
+matchRoute' routes (Just (matched, RouteMatchOrVar r vars, "")) ps dsp =
+ -- The matched key is also a prefix of other routes, but the
+ -- entire path matched so handle like a RouteMatch.
+ matchRoute' routes (Just (matched, RouteMatch r vars, "")) ps dsp
+matchRoute' _routes (Just (matched, RouteMatch r vars, "")) ps dsp =
+ -- The entire path matched so return the resource, params, and
+ -- dispatch path
+ Just (r, (fromList $ zip vars ps, dispatchList dsp matched))
+ where
+ dispatchList (Just d) m = toTextList $ B.concat [d, m]
+ dispatchList Nothing _ = mempty
+ toTextList bs = decodeUtf8 <$> BC8.split '/' bs
+matchRoute' _routes (Just (_matched, RouteMatch _r _vars, _)) _ps _dsp =
+ -- Part of the request path matched, but the trie value at the
+ -- matched prefix is not an RVar or RouteMatchOrVar so there is no
+ -- match.
+ Nothing
+matchRoute' routes (Just (matched, RouteMatchOrVar _r _vars, rest)) ps dsp =
+ -- Part of the request path matched and the trie value at the
+ -- matched prefix is a RouteMatchOrVar so handle it the same as if
+ -- the value were RVar.
+ matchRoute' routes (Just (matched, RVar, rest)) ps dsp
+matchRoute' routes (Just (matched, RVar, rest)) ps dsp
+ | BC8.null rest = Nothing
+ | BC8.take 2 rest == "//" = Nothing
+ | BC8.head rest == '/' =
+ -- Part of the request path matched and the trie value at the
+ -- matched prefix is a RVar so calculate the key for the next part
+ -- of the route and continue attempting to match.
+ let nextKey = B.concat [ Base64.encode $ B.concat [matched, "var"]
+ , BC8.dropWhile (/='/') $ BC8.dropWhile (=='/') rest
+ ]
+ updDsp = if isNothing dsp then Just mempty
+ else dsp
+ paramVal = decodeUtf8 . BC8.takeWhile (/='/')
+ $ BC8.dropWhile (=='/') rest
+ matchRes = Trie.match routes nextKey
+ in matchRoute' routes matchRes (paramVal:ps) updDsp
+ | otherwise = Nothing
+matchRoute' _routes (Just (_matched, Wildcard r, rest)) _ps _dsp =
+ -- Encountered a wildcard (star) value in the trie so it's a match
+ Just (r, (mempty, decodeUtf8 <$> [BC8.dropWhile (=='/') rest]))
diff --git a/src/Airship/RST.hs b/src/Airship/RST.hs
new file mode 100644
index 0000000..e3e5f7e
--- /dev/null
+++ b/src/Airship/RST.hs
@@ -0,0 +1,161 @@
+{-
+ This file is copyright (c) 2009, the Snap Framework authors,
+ and Patrick Thomson (for the Airship project).
+ Used under the three-clause BSD license, the text of which may be
+ found in the LICENSE file in the Airship root.
+-}
+
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+{-
+ RST is like the RWST monad, but has no Writer instance, as Writer leaks space.
+ This file is almost entirely lifted from the Snap framework's implementation.
+-}
+
+module Airship.RST
+ ( RST (..)
+ , evalRST
+ , execRST
+ , mapRST
+ , withRST
+ , failure
+ ) where
+
+import Control.Applicative (Alternative (..),
+ Applicative (..))
+import Control.Category ((.))
+import Control.Monad (MonadPlus (..), ap)
+import Control.Monad.Base (MonadBase (..))
+import Control.Monad.Reader (MonadReader (..))
+import Control.Monad.State.Class (MonadState (..))
+import Control.Monad.Trans (MonadIO (..), MonadTrans (..))
+import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..),
+ MonadTransControl (..),
+ defaultLiftBaseWith,
+ defaultRestoreM)
+import Data.Either
+import Prelude (Functor (..), Monad (..), seq,
+ ($), ($!))
+
+
+newtype RST r s e m a = RST { runRST :: r -> s -> m (Either e a, s) }
+
+
+evalRST :: Monad m => RST r s e m a -> r -> s -> m (Either e a)
+evalRST m r s = do
+ (res, _) <- runRST m r s
+ return $! res
+{-# INLINE evalRST #-}
+
+
+execRST :: Monad m => RST r s e m a -> r -> s -> m s
+execRST m r s = do
+ (_,!s') <- runRST m r s
+ return $! s'
+{-# INLINE execRST #-}
+
+
+withRST :: Monad m => (r' -> r) -> RST r s e m a -> RST r' s e m a
+withRST f m = RST $ \r' s -> runRST m (f r') s
+{-# INLINE withRST #-}
+
+
+instance (Monad m) => MonadReader r (RST r s e m) where
+ ask = RST $ \r s -> return $! (Right r,s)
+ local f m = RST $ \r s -> runRST m (f r) s
+
+-- Terrible hack to work around the fact that Functor isn't a superclass
+-- of Monad on GHC 7.8. TODO kill this when 7.8 support is dropped
+#if __GLASGOW_HASKELL__ == 708
+instance (Monad m) => Functor (RST r s e m) where
+ fmap f m = RST $ \r s -> runRST m r s >>= helper where
+ helper (a, s') = case a of
+ (Left l) -> return $! (Left l, s')
+ (Right r) -> return $! (Right $ f r, s')
+#else
+instance (Functor m) => Functor (RST r s e m) where
+ fmap f m = RST $ \r s -> fmap (\(a,s') -> (fmap f a, s')) $ runRST m r s
+#endif
+
+instance Monad m => Applicative (RST r s e m) where
+ pure = return
+ (<*>) = ap
+
+
+instance MonadPlus m => Alternative (RST r s e m) where
+ empty = mzero
+ (<|>) = mplus
+
+
+instance (Monad m) => MonadState s (RST r s e m) where
+ get = RST $ \_ s -> return $! (Right s,s)
+ put x = RST $ \_ _ -> return $! (Right (),x)
+ state act = RST $ \_ s -> do
+ let (res, !s') = act s
+ return $! (Right res, s')
+
+
+mapRST :: (m (Either e a, s) -> n (Either e b, s)) -> RST r s e m a -> RST r s e n b
+mapRST f m = RST $ \r s -> f (runRST m r s)
+
+rwsBind :: Monad m =>
+ RST r s e m a
+ -> (a -> RST r s e m b)
+ -> RST r s e m b
+rwsBind m f = RST go
+ where
+ go r !s = do
+ (a, !s') <- runRST m r s
+ case a of
+ Left e -> return $! (Left e, s')
+ Right a' -> runRST (f a') r s'
+{-# INLINE rwsBind #-}
+
+instance (Monad m) => Monad (RST r s e m) where
+ return a = RST $ \_ s -> return $! (Right a, s)
+ (>>=) = rwsBind
+ fail msg = RST $ \_ _ -> fail msg
+
+
+instance (MonadPlus m) => MonadPlus (RST r s e m) where
+ mzero = RST $ \_ _ -> mzero
+ m `mplus` n = RST $ \r s -> runRST m r s `mplus` runRST n r s
+
+
+instance (MonadIO m) => MonadIO (RST r s e m) where
+ liftIO = lift . liftIO
+
+
+instance MonadTrans (RST r s e) where
+ lift m = RST $ \_ s -> do
+ a <- m
+ return $ s `seq` (Right a, s)
+
+
+instance MonadBase b m => MonadBase b (RST r s e m) where
+ liftBase = lift . liftBase
+
+
+instance MonadBaseControl b m => MonadBaseControl b (RST r s e m) where
+ type StM (RST r s e m) a = ComposeSt (RST r s e) m a
+ liftBaseWith = defaultLiftBaseWith
+ restoreM = defaultRestoreM
+ {-# INLINE liftBaseWith #-}
+ {-# INLINE restoreM #-}
+
+instance MonadTransControl (RST r s e) where
+ type StT (RST r s e) a = (Either e a, s)
+ liftWith f = RST $ \r s -> do
+ res <- f $ \(RST g) -> g r s
+ return $! (Right res, s)
+ restoreT k = RST $ \_ _ -> k
+ {-# INLINE liftWith #-}
+ {-# INLINE restoreT #-}
+
+failure :: Monad m => e -> RST r s e m a
+failure e = RST $ \_ s -> return $! (Left e, s)
diff --git a/src/Airship/Resource.hs b/src/Airship/Resource.hs
index c78e8a7..77f90be 100644
--- a/src/Airship/Resource.hs
+++ b/src/Airship/Resource.hs
@@ -15,7 +15,7 @@ import Airship.Types
import Data.ByteString (ByteString)
#if __GLASGOW_HASKELL__ < 710
-import Data.Monoid (mempty)
+import Data.Monoid (mappend, mempty)
#endif
import Data.Text (Text)
import Data.Time.Clock (UTCTime)
@@ -116,6 +116,7 @@ data Resource m =
, errorResponses :: ErrorResponses m
}
+
-- | A helper function that terminates execution with @500 Internal Server Error@.
serverError :: Monad m => Webmachine m a
serverError = finishWith (Response status500 [] Empty)
diff --git a/src/Airship/Route.hs b/src/Airship/Route.hs
index d7eb153..014f71e 100644
--- a/src/Airship/Route.hs
+++ b/src/Airship/Route.hs
@@ -1,12 +1,15 @@
module Airship.Route
( Route
, RoutingSpec
+ , RouteLeaf
+ , Trie
, root
, var
, star
, (</>)
, (#>)
+ , (#>=)
+ , runRouter
) where
-import Airship.Types
import Airship.Internal.Route
diff --git a/src/Airship/Types.hs b/src/Airship/Types.hs
index f1109f2..a03d994 100644
--- a/src/Airship/Types.hs
+++ b/src/Airship/Types.hs
@@ -13,11 +13,14 @@
module Airship.Types
( ETag(..)
, Webmachine
+ , AirshipRequest(..)
, Request(..)
+ , RequestReader(..)
, Response(..)
, ResponseState(..)
, ResponseBody(..)
, ErrorResponses
+ , addTrace
, defaultRequest
, entireRequestBody
, etagToByteString
@@ -27,6 +30,7 @@ module Airship.Types
, runWebmachine
, request
, requestTime
+ , routePath
, getResponseHeaders
, getResponseBody
, params
@@ -35,9 +39,9 @@ module Airship.Types
, putResponseBS
, halt
, finishWith
- , (#>)
) where
+import Airship.RST
import Blaze.ByteString.Builder (Builder)
import Blaze.ByteString.Builder.ByteString (fromByteString)
import Blaze.ByteString.Builder.Html.Utf8 (fromHtmlEscapedText)
@@ -51,14 +55,9 @@ import Control.Monad.Base (MonadBase)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Morph
import Control.Monad.Reader.Class (MonadReader, ask)
-import Control.Monad.State.Class (MonadState, get, modify)
+import Control.Monad.State.Class
import Control.Monad.Trans.Control (MonadBaseControl (..))
-import Control.Monad.Trans.Either (EitherT (..), left,
- mapEitherT, runEitherT)
-import Control.Monad.Trans.RWS.Strict (RWST (..), mapRWST,
- runRWST)
-import Control.Monad.Writer.Class (MonadWriter, tell)
-import Data.ByteString.Char8
+import Data.ByteString.Char8 hiding (reverse)
import Data.HashMap.Strict (HashMap)
import Data.Map.Strict (Map)
import Data.Monoid ((<>))
@@ -82,9 +81,15 @@ entireRequestBody req = liftIO (requestBody req) >>= strictRequestBody' LB.empty
| BS.null prev = return acc
| otherwise = liftIO (requestBody req) >>= strictRequestBody' (acc <> LB.fromStrict prev)
-data RequestReader = RequestReader { _now :: UTCTime
- , _request :: Request
- }
+data RequestReader = RequestReader
+ { _now :: UTCTime
+ , _airshipRequest :: AirshipRequest
+ }
+
+data AirshipRequest = AirshipRequest
+ { _request :: Request
+ , _routePath :: Text
+ }
data ETag = Strong ByteString
| Weak ByteString
@@ -117,24 +122,27 @@ data ResponseState = ResponseState { stateHeaders :: ResponseHeaders
, stateBody :: ResponseBody
, _params :: HashMap Text Text
, _dispatchPath :: [Text]
+ , decisionTrace :: Trace
}
-type Trace = [Text]
+type Trace = [ByteString]
type ErrorResponses m = Monad m => Map HTTP.Status [(MediaType, Webmachine m ResponseBody)]
newtype Webmachine m a =
- Webmachine { getWebmachine :: EitherT Response (RWST RequestReader Trace ResponseState m) a }
+ Webmachine { getWebmachine :: (RST RequestReader ResponseState Response m) a }
deriving (Functor, Applicative, Monad, MonadIO, MonadBase b,
MonadReader RequestReader,
- MonadWriter Trace,
MonadState ResponseState)
instance MonadTrans Webmachine where
- lift = Webmachine . EitherT . (>>= return . Right) . lift
+ lift = Webmachine . RST . helper where
+ helper m _ s = do
+ a <- m
+ return $ (Right a, s)
newtype StMWebmachine m a = StMWebmachine {
- unStMWebmachine :: StM (EitherT Response (RWST RequestReader Trace ResponseState m)) a
+ unStMWebmachine :: StM (RST RequestReader ResponseState Response m) a
}
instance MonadBaseControl b m => MonadBaseControl b (Webmachine m) where
@@ -146,12 +154,27 @@ instance MonadBaseControl b m => MonadBaseControl b (Webmachine m) where
$ g' $ getWebmachine m
restoreM = Webmachine . restoreM . unStMWebmachine
+-- Work around old versions of mtl not having a strict modify function
+modify'' :: MonadState s m => (s -> s) -> m ()
+#if MIN_VERSION_mtl(2,2,0)
+modify'' = modify'
+#else
+modify'' f = state (\s -> let s' = f s in s' `seq` ((), s'))
+#endif
+
-- Functions inside the Webmachine Monad -------------------------------------
------------------------------------------------------------------------------
-- | Returns the 'Request' that is currently being processed.
request :: Monad m => Webmachine m Request
-request = _request <$> ask
+request = _request . _airshipRequest <$> ask
+
+-- | Returns the route path that was matched during route evaluation. This is
+-- not the path specified in the request, but rather the route in the
+-- 'RoutingSpec' that matched the request URL. Variables names are prefixed
+-- with @:@, and free ("star") paths are designated with @*@.
+routePath :: Monad m => Webmachine m Text
+routePath = _routePath . _airshipRequest <$> ask
-- | Returns the bound routing parameters extracted from the routing system (see "Airship.Route").
params :: Monad m => Webmachine m (HashMap Text Text)
@@ -174,7 +197,7 @@ getResponseBody = stateBody <$> get
-- | Given a new 'ResponseBody', replaces the stored body with the new one.
putResponseBody :: Monad m => ResponseBody -> Webmachine m ()
-putResponseBody b = modify updateState
+putResponseBody b = modify'' updateState
where updateState rs = rs {stateBody = b}
-- | Stores the provided 'ByteString' as the responseBody. This is a shortcut for
@@ -191,47 +214,27 @@ halt status = finishWith =<< Response <$> return status <*> getResponseHeaders <
-- | Immediately halts processing and writes the provided 'Response' back to the client.
finishWith :: Monad m => Response -> Webmachine m a
-finishWith = Webmachine . left
-
--- | The @#>@ operator provides syntactic sugar for the construction of association lists.
--- For example, the following assoc list:
---
--- @
--- [("run", "jewels"), ("blue", "suede"), ("zion", "wolf")]
--- @
---
--- can be represented as such:
---
--- @
--- execWriter $ do
--- "run" #> "jewels"
--- "blue" #> "suede"
--- "zion" #> "wolf"
--- @
---
--- It used in 'RoutingSpec' declarations to indicate that a particular 'Route' maps
--- to a given 'Resource', but can be used in many other places where association lists
--- are expected, such as 'contentTypesProvided'.
-(#>) :: MonadWriter [(k, v)] m => k -> v -> m ()
-k #> v = tell [(k, v)]
+finishWith = Webmachine . failure
+
+-- | Adds the provided ByteString to the Airship-Trace header.
+addTrace :: Monad m => ByteString -> Webmachine m ()
+addTrace t = modify'' (\s -> s { decisionTrace = t : decisionTrace s })
both :: Either a a -> a
both = either id id
-eitherResponse :: Monad m => UTCTime -> HashMap Text Text -> [Text] -> Request -> Webmachine m Response -> m (Response, Trace)
-eitherResponse reqDate reqParams dispatched req resource = do
- (e, trace) <- runWebmachine reqDate reqParams dispatched req resource
+eitherResponse :: Monad m => RequestReader -> ResponseState -> Webmachine m Response -> m (Response, Trace)
+eitherResponse requestReader startingState w = do
+ (e, trace) <- runWebmachine requestReader startingState w
return (both e, trace)
-- | Map both the return value and wrapped computation @m@.
-mapWebmachine :: ( m1 (Either Response a1, ResponseState, Trace)
- -> m2 (Either Response a2, ResponseState, Trace) )
+mapWebmachine :: ( m1 (Either Response a1, ResponseState)
+ -> m2 (Either Response a2, ResponseState))
-> Webmachine m1 a1 -> Webmachine m2 a2
-mapWebmachine f = Webmachine . (mapEitherT $ mapRWST f) . getWebmachine
-
-runWebmachine :: Monad m => UTCTime -> HashMap Text Text -> [Text] -> Request -> Webmachine m a -> m (Either (Response) a, Trace)
-runWebmachine reqDate reqParams dispatched req w = do
- let startingState = ResponseState [] Empty reqParams dispatched
- requestReader = RequestReader reqDate req
- (e, _, t) <- runRWST (runEitherT (getWebmachine w)) requestReader startingState
- return (e, t)
+mapWebmachine f = Webmachine . (mapRST f) . getWebmachine
+
+runWebmachine :: Monad m => RequestReader -> ResponseState -> Webmachine m a -> m (Either Response a, Trace)
+runWebmachine requestReader startingState w = do
+ (e, s) <- runRST (getWebmachine w) requestReader startingState
+ return (e, reverse $ decisionTrace s)